diff options
Diffstat (limited to 'third_party/lisp')
222 files changed, 25871 insertions, 122 deletions
diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS new file mode 100644 index 000000000000..2d7f7e237b76 --- /dev/null +++ b/third_party/lisp/OWNERS @@ -0,0 +1,5 @@ +# -*- mode: yaml; -*- +inherited: true +owners: + - eta + - grfn diff --git a/third_party/lisp/alexandria/.boring b/third_party/lisp/alexandria/.boring new file mode 100644 index 000000000000..dfa9e6dd7bb4 --- /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 000000000000..e832e9471833 --- /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 000000000000..b550ea503248 --- /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 000000000000..b5140fbb2491 --- /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 000000000000..a5dae9ed1ac7 --- /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 000000000000..445c18cf7f77 --- /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 000000000000..db10e4f53710 --- /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 000000000000..76c18791ad5f --- /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 000000000000..37a3d52fb9f0 --- /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 000000000000..ac471cca7e4c --- /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 000000000000..dd00df3e1620 --- /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 000000000000..2358c898b3ab --- /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/ +{ depot, ... }: + +depot.nix.buildLisp.library { + name = "alexandria"; + srcs = [ + ./package.lisp + ./definitions.lisp + ./binding.lisp + ./strings.lisp + ./conditions.lisp + ./symbols.lisp + ./macros.lisp + ./functions.lisp + ./io.lisp + ./hash-tables.lisp + ./control-flow.lisp + ./lists.lisp + ./types.lisp + ./arrays.lisp + ./sequences.lisp + ./numbers.lisp + ./features.lisp + ]; +} diff --git a/third_party/lisp/alexandria/definitions.lisp b/third_party/lisp/alexandria/definitions.lisp new file mode 100644 index 000000000000..863e1f696286 --- /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 000000000000..f22577b3ac86 --- /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 000000000000..85eb818220d5 --- /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 000000000000..89b03ac34967 --- /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 000000000000..51dda07d09b7 --- /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 000000000000..67348dbba43b --- /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 000000000000..dd83e38b4ebc --- /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 000000000000..a9f790220405 --- /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 000000000000..28bf5e6d82c7 --- /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 000000000000..51286071ebf2 --- /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 000000000000..4364ad63b82a --- /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 000000000000..1c06f71d508f --- /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 000000000000..f9d2014cd7b5 --- /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 000000000000..21464f537610 --- /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 000000000000..e9fd91c96155 --- /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 000000000000..5733d3e1cc50 --- /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 000000000000..b70ef0475e81 --- /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 000000000000..1942d0ecdf2a --- /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/anaphora.nix b/third_party/lisp/anaphora.nix index bf4bf663f4d4..d2356f7b05ea 100644 --- a/third_party/lisp/anaphora.nix +++ b/third_party/lisp/anaphora.nix @@ -1,17 +1,18 @@ -{ depot, ... }: +{ depot, pkgs, ... }: -let - src = builtins.fetchGit { - url = "https://github.com/tokenrove/anaphora.git"; - rev = "aeace4c68cf55098a67112750b28f8f2dc6d0e30"; +let src = pkgs.fetchFromGitHub { + owner = "tokenrove"; + repo = "anaphora"; + rev = "018590df36ffb30ece561fb28ea6521363efc6e2"; + sha256 = "0pq6y5swvrjd0kjs2dl2648s13s0pzxin0chrq35jam8jrci3kd1"; }; in depot.nix.buildLisp.library { name = "anaphora"; - deps = []; - srcs = [ - "${src}/packages.lisp" - "${src}/early.lisp" - "${src}/symbolic.lisp" - "${src}/anaphora.lisp" + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "early.lisp" + "symbolic.lisp" + "anaphora.lisp" ]; } diff --git a/third_party/lisp/asdf-flv/.gitattributes b/third_party/lisp/asdf-flv/.gitattributes new file mode 100644 index 000000000000..2b45716e4709 --- /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 000000000000..bdf4ad2ae6dd --- /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 000000000000..b4c74feefe82 --- /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 000000000000..7ccdd1888163 --- /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 000000000000..76c6845b82b3 --- /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 000000000000..e8ec4aa8f85c --- /dev/null +++ b/third_party/lisp/asdf-flv/default.nix @@ -0,0 +1,13 @@ +# Imported from https://github.com/didierverna/asdf-flv +{ depot, ... }: + +with depot.nix; +buildLisp.library { + name = "asdf-flv"; + deps = [ (buildLisp.bundled "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 000000000000..41202746d019 --- /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 000000000000..1d7fb2bab43d --- /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/babel.nix b/third_party/lisp/babel.nix new file mode 100644 index 000000000000..c4a49e833f76 --- /dev/null +++ b/third_party/lisp/babel.nix @@ -0,0 +1,34 @@ +# Babel is an encoding conversion library for Common Lisp. +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/cl-babel/babel.git"; + rev = "f892d0587c7f3a1e6c0899425921b48008c29ee3"; # 2020-07-19 +}; +in depot.nix.buildLisp.library { + name = "babel"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.trivial-features + ]; + + 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 000000000000..92bc1f2629c4 --- /dev/null +++ b/third_party/lisp/bordeaux-threads.nix @@ -0,0 +1,26 @@ +# This library is meant to make writing portable multi-threaded apps +# in Common Lisp simple. +{ depot, ... }: + +let + src = builtins.fetchGit { + url = "https://github.com/sionescu/bordeaux-threads.git"; + rev = "499b6d3f0ce635417d6096acf0a671d8bf3f6e5f"; + }; + getSrc = f: "${src}/src/${f}"; +in depot.nix.buildLisp.library { + name = "bordeaux-threads"; + deps = [ depot.third_party.lisp.alexandria ]; + + srcs = map getSrc [ + "pkgdcl.lisp" + "bordeaux-threads.lisp" + ] ++ [ + { + sbcl = getSrc "impl-sbcl.lisp"; + ecl = getSrc "impl-ecl.lisp"; + } + ] ++ map getSrc [ + "default-implementations.lisp" + ]; +} diff --git a/third_party/lisp/cffi.nix b/third_party/lisp/cffi.nix new file mode 100644 index 000000000000..c8d240c8cd0e --- /dev/null +++ b/third_party/lisp/cffi.nix @@ -0,0 +1,37 @@ +# CFFI purports to be the Common Foreign Function Interface. +{ depot, ... }: + +with depot.nix; +let src = builtins.fetchGit { + url = "https://github.com/cffi/cffi.git"; + rev = "a49ff36a95cb62ffa6cb069d98378d665769926b"; +}; +in buildLisp.library { + name = "cffi"; + deps = with depot.third_party.lisp; [ + alexandria + babel + trivial-features + (buildLisp.bundled "asdf") + ]; + + srcs = [ + { + ecl = src + "/src/cffi-ecl.lisp"; + sbcl = src + "/src/cffi-sbcl.lisp"; + ccl = src + "/src/cffi-openmcl.lisp"; + } + ] ++ map (f: src + ("/src/" + f)) [ + "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/checkl.nix b/third_party/lisp/checkl.nix new file mode 100644 index 000000000000..4fb92cb37937 --- /dev/null +++ b/third_party/lisp/checkl.nix @@ -0,0 +1,26 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + + src = pkgs.fetchFromGitHub { + owner = "rpav"; + repo = "CheckL"; + rev = "80328800d047fef9b6e32dfe6bdc98396aee3cc9"; + sha256 = "0bpisihx1gay44xmyr1dmhlwh00j0zzi04rp9fy35i95l2r4xdlx"; + }; + +in depot.nix.buildLisp.library { + name = "checkl"; + deps = with depot.third_party.lisp; [ + (bundled "asdf") + marshal + fiveam + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "checkl.lisp" + "formalize.lisp" + ]; +} diff --git a/third_party/lisp/chipz.nix b/third_party/lisp/chipz.nix new file mode 100644 index 000000000000..2a68d3b1f8e9 --- /dev/null +++ b/third_party/lisp/chipz.nix @@ -0,0 +1,31 @@ +# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "froydnj"; + repo = "chipz"; + rev = "75dfbc660a5a28161c57f115adf74c8a926bfc4d"; + sha256 = "0plx4rs39zbs4gjk77h4a2q11zpy75fh9v8hnxrvsf8fnakajhwg"; +}; +in depot.nix.buildLisp.library { + name = "chipz"; + deps = [ (depot.nix.buildLisp.bundled "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 000000000000..d40208063372 --- /dev/null +++ b/third_party/lisp/chunga.nix @@ -0,0 +1,27 @@ +# Portable chunked streams for Common Lisp +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "chunga"; + rev = "16330852d01dfde4dd97dee7cd985a88ea571e7e"; + sha256 = "0jzn3nyb3f22gm983rfk99smqs3mhb9ivjmasvhq9qla5cl9pyhd"; +}; +in depot.nix.buildLisp.library { + name = "chunga"; + deps = with depot.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 000000000000..5c01e023265a --- /dev/null +++ b/third_party/lisp/cl-ansi-text.nix @@ -0,0 +1,19 @@ +# Enables ANSI colors for printing. +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/pnathan/cl-ansi-text.git"; + rev = "257a5f19a2dc92d22f8fd772c0a78923b99b36a8"; +}; +in depot.nix.buildLisp.library { + name = "cl-ansi-text"; + deps = with depot.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-arrows.nix b/third_party/lisp/cl-arrows.nix deleted file mode 100644 index 4c09d688fae7..000000000000 --- a/third_party/lisp/cl-arrows.nix +++ /dev/null @@ -1,15 +0,0 @@ -{ depot, ... }: - -let - src = builtins.fetchGit { - url = "https://github.com/nightfly19/cl-arrows.git"; - rev = "cbb46b69a7de40f1161c9caaf6cef93b3af9994f"; - }; -in depot.nix.buildLisp.library { - name = "cl-arrows"; - deps = []; - srcs = [ - "${src}/packages.lisp" - "${src}/arrows.lisp" - ]; -} diff --git a/third_party/lisp/cl-base64.nix b/third_party/lisp/cl-base64.nix new file mode 100644 index 000000000000..1152601a81d3 --- /dev/null +++ b/third_party/lisp/cl-base64.nix @@ -0,0 +1,17 @@ +# Base64 encoding for Common Lisp +{ depot, ... }: + +let src = builtins.fetchGit { + url = "http://git.kpe.io/cl-base64.git"; + rev = "fc62a5342445d4ec1dd44e95f7dc513473a8c89a"; +}; +in depot.nix.buildLisp.library { + name = "cl-base64"; + srcs = [ + (src + "/package.lisp") + (src + "/encode.lisp") + (src + "/decode.lisp") + ]; +} + + diff --git a/third_party/lisp/cl-colors.nix b/third_party/lisp/cl-colors.nix deleted file mode 100644 index fa35b755dbbc..000000000000 --- a/third_party/lisp/cl-colors.nix +++ /dev/null @@ -1,20 +0,0 @@ -{ depot, briefcase, ... }: - -let - src = builtins.fetchGit { - url = "https://github.com/tpapp/cl-colors.git"; - rev = "827410584553f5c717eec6182343b7605f707f75"; - }; -in depot.nix.buildLisp.library { - name = "cl-colors"; - deps = [ - depot.third_party.lisp.alexandria - briefcase.third_party.lisp.let-plus - ]; - srcs = [ - "${src}/package.lisp" - "${src}/colors.lisp" - "${src}/colornames.lisp" - "${src}/hexcolors.lisp" - ]; -} diff --git a/third_party/lisp/cl-colors2.nix b/third_party/lisp/cl-colors2.nix new file mode 100644 index 000000000000..c90b8eae0118 --- /dev/null +++ b/third_party/lisp/cl-colors2.nix @@ -0,0 +1,21 @@ + +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://notabug.org/cage/cl-colors2.git"; + rev = "795aedee593b095fecde574bd999b520dd03ed24"; +}; +in depot.nix.buildLisp.library { + name = "cl-colors2"; + deps = with depot.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 000000000000..905e0821cac7 --- /dev/null +++ b/third_party/lisp/cl-fad.nix @@ -0,0 +1,32 @@ +# Portable pathname library +{ depot, pkgs, ...}: + +with depot.nix; + +let src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "cl-fad"; + rev = "13cbffe08fc660041359302f4057f8fc20d09402"; # 2021-01-10 + sha256 = "049laj8an6g9bh0m0cn0bxhq313p8qq1h37cil15l66147ad8slc"; +}; +in buildLisp.library { + name = "cl-fad"; + + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + { + sbcl = buildLisp.bundled "sb-posix"; + } + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + ] ++ [ + { ccl = "${src}/openmcl.lisp"; } + ] ++ map (f: src + ("/" + f)) [ + "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 000000000000..5d1450a3e9a1 --- /dev/null +++ b/third_party/lisp/cl-json.nix @@ -0,0 +1,28 @@ +# JSON encoder & decoder +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + + src = pkgs.fetchFromGitHub { + owner = "hankhero"; + repo = "cl-json"; + rev = "6dfebb9540bfc3cc33582d0c03c9ec27cb913e79"; + sha256 = "0fx3m3x3s5ji950yzpazz4s0img3l6b3d6l3jrfjv0lr702496lh"; + }; +in buildLisp.library { + name = "cl-json"; + deps = [ (buildLisp.bundled "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 000000000000..e6a616b95e46 --- /dev/null +++ b/third_party/lisp/cl-plus-ssl.nix @@ -0,0 +1,47 @@ +# Common Lisp bindings to OpenSSL +{ depot, pkgs, ... }: + +with depot.nix; + +let src = builtins.fetchGit { + url = "https://github.com/cl-plus-ssl/cl-plus-ssl.git"; + rev = "29081992f6d7b4e3aa2c5eeece4cd92b745071f4"; +}; +in buildLisp.library { + name = "cl-plus-ssl"; + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + cffi + flexi-streams + trivial-features + trivial-garbage + trivial-gray-streams + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + { sbcl = buildLisp.bundled "sb-posix"; } + ]; + + native = [ pkgs.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" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/cl-ppcre.nix b/third_party/lisp/cl-ppcre.nix new file mode 100644 index 000000000000..1dc9eb553118 --- /dev/null +++ b/third_party/lisp/cl-ppcre.nix @@ -0,0 +1,30 @@ +# cl-ppcre is a Common Lisp regular expression library. +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/edicl/cl-ppcre"; + rev = "1ca0cd9ca0d161acd49c463d6cb5fff897596e2f"; +}; +in depot.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 000000000000..f793136194cb --- /dev/null +++ b/third_party/lisp/cl-prevalence.nix @@ -0,0 +1,30 @@ +# cl-prevalence is an implementation of object prevalence for CL (i.e. +# an in-memory database) +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "40ants"; + repo = "cl-prevalence"; + rev = "b1f90a525f37be0335a8761051fa5661aa74b696"; + sha256 = "1svw58pp7jxb9l08cgnqxf0cf8qa9qsb0z2fnv86a51z7pfz4c0g"; +}; +in depot.nix.buildLisp.library { + name = "cl-prevalence"; + + deps = with depot.third_party.lisp; [ + bordeaux-threads + 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/cl-smtp.nix b/third_party/lisp/cl-smtp.nix new file mode 100644 index 000000000000..a9905b5ef6f5 --- /dev/null +++ b/third_party/lisp/cl-smtp.nix @@ -0,0 +1,32 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitLab { + domain = "gitlab.common-lisp.net"; + owner = "cl-smtp"; + repo = "cl-smtp"; + rev = "ed47d326fad867ee11323fa3a0f307b5d40e8f2b"; + sha256 = "0vjjfapcrdc5671jz2d24h8zvpz7skq1x6pi9fvw6ls5sgms6fr0"; + }; + +in depot.nix.buildLisp.library { + name = "cl-smtp"; + deps = with depot.third_party.lisp; [ + usocket + trivial-gray-streams + flexi-streams + cl-base64 + cl-plus-ssl + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "attachments.lisp" + "cl-smtp.lisp" + "mime-types.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/cl-unicode.nix b/third_party/lisp/cl-unicode.nix new file mode 100644 index 000000000000..5fff1fbe6bb2 --- /dev/null +++ b/third_party/lisp/cl-unicode.nix @@ -0,0 +1,80 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) sbcl runCommand writeText; + inherit (depot.nix.buildLisp) bundled; + + src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "cl-unicode"; + rev = "8073fc5634c9d4802888ac03abf11dfe383e16fa"; + sha256 = "0ykx2s9lqfl74p1px0ik3l2izd1fc9jd1b4ra68s5x34rvjy0hza"; + }; + + cl-unicode-base = depot.nix.buildLisp.library { + name = "cl-unicode-base"; + deps = with depot.third_party.lisp; [ + cl-ppcre + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + ]; + }; + + cl-unicode-build = depot.nix.buildLisp.program { + name = "cl-unicode-build"; + deps = with depot.third_party.lisp; [ + cl-unicode-base + flexi-streams + { + ecl = bundled "asdf"; + default = bundled "uiop"; + } + ]; + + srcs = (map (f: src + ("/build/" + f)) [ + "util.lisp" + "char-info.lisp" + "read.lisp" + ]) ++ [ + (runCommand "dump.lisp" {} '' + substitute ${src}/build/dump.lisp $out \ + --replace ':defaults *this-file*' ":defaults (uiop:getcwd)" + '') + + (writeText "export-create-source-files.lisp" '' + (in-package :cl-unicode) + (export 'create-source-files) + '') + ]; + + main = "cl-unicode:create-source-files"; + }; + + + generated = runCommand "cl-unicode-generated" {} '' + mkdir -p $out/build + mkdir -p $out/test + cd $out/build + pwd + ${cl-unicode-build}/bin/cl-unicode-build + ''; + +in +depot.nix.buildLisp.library { + name = "cl-unicode"; + deps = [cl-unicode-base]; + srcs = [ + "${src}/conditions.lisp" + "${generated}/lists.lisp" + "${generated}/hash-tables.lisp" + "${src}/api.lisp" + "${generated}/methods.lisp" + "${src}/test-functions.lisp" + "${src}/derived.lisp" + "${src}/alias.lisp" + ]; +} diff --git a/third_party/lisp/cl-who.nix b/third_party/lisp/cl-who.nix new file mode 100644 index 000000000000..50e4e68c0348 --- /dev/null +++ b/third_party/lisp/cl-who.nix @@ -0,0 +1,21 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "cl-who"; + rev = "0d3826475133271ee8c590937136c1bc41b8cbe0"; + sha256 = "0sc8nji9q1df04lhsiwsjy1a35996bibl31w5hp5sh8q6sa122dy"; + }; + +in depot.nix.buildLisp.library { + name = "cl-who"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "who.lisp" + ]; +} diff --git a/third_party/lisp/cl-yacc.nix b/third_party/lisp/cl-yacc.nix new file mode 100644 index 000000000000..d2ceb81103e2 --- /dev/null +++ b/third_party/lisp/cl-yacc.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "jech"; + repo = "cl-yacc"; + rev = "1334f5469251ffb3f8738a682dc8ee646cb26635"; + sha256 = "16946pzf8vvadnyfayvj8rbh4zjzw90h0azz2qk1mxrvhh5wklib"; + }; +in depot.nix.buildLisp.library { + name = "cl-yacc"; + + srcs = map (f: src + ("/" + f)) [ + "yacc.lisp" + ]; +} diff --git a/third_party/lisp/closer-mop.nix b/third_party/lisp/closer-mop.nix new file mode 100644 index 000000000000..21fb3ba14bef --- /dev/null +++ b/third_party/lisp/closer-mop.nix @@ -0,0 +1,24 @@ +# Closer to MOP is a compatibility layer that rectifies many of the +# absent or incorrect CLOS MOP features across a broad range of Common +# Lisp implementations +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "pcostanza"; + repo = "closer-mop"; + rev = "8ec9577029b08ade5978236121c9ac276f78d8be"; # 2021-07-30 + sha256 = "0dm8xsa3hzpxjd7x248pbzd8blw01a8ls7spalzgbg1g7vbn6zg5"; +}; +in depot.nix.buildLisp.library { + name = "closer-mop"; + + srcs = [ + "${src}/closer-mop-packages.lisp" + "${src}/closer-mop-shared.lisp" + { + sbcl = "${src}/closer-sbcl.lisp"; + ecl = "${src}/closer-ecl.lisp"; + ccl = "${src}/closer-clozure.lisp"; + } + ]; +} diff --git a/third_party/lisp/closure-common.nix b/third_party/lisp/closure-common.nix new file mode 100644 index 000000000000..591620e48705 --- /dev/null +++ b/third_party/lisp/closure-common.nix @@ -0,0 +1,43 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "sharplispers"; + repo = "closure-common"; + rev = "e3c5f5f454b72b01b89115e581c3c52a7e201e5c"; # 2018-09-09 + sha256 = "0k5r2qxn122pxi301ijir3nayi9sg4d7yiy276l36qmzwhp4mg5n"; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); +in + +depot.nix.buildLisp.library { + name = "closure-common"; + + # closure-common.asd surpresses some warnings otherwise breaking + # compilation. Feature macros across implementations: + # + # ECL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # CCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # SBCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # + # Since all implementations agree, the alternative files aren't encoded here. + srcs = getSrcs [ + "closure-common.asd" + "package.lisp" + "definline.lisp" + "characters.lisp" #+rune-is-character + "syntax.lisp" + "encodings.lisp" #-x&y-streams-are-stream + "encodings-data.lisp" #-x&y-streams-are-stream + "xstream.lisp" #-x&y-streams-are-stream + "ystream.lisp" #-x&y-streams-are-stream + "hax.lisp" + ]; + + deps = [ + (depot.nix.buildLisp.bundled "asdf") + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.babel #+rune-is-character + ]; +} diff --git a/third_party/lisp/closure-html/default.nix b/third_party/lisp/closure-html/default.nix new file mode 100644 index 000000000000..32ab49f8d479 --- /dev/null +++ b/third_party/lisp/closure-html/default.nix @@ -0,0 +1,70 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + name = "closure-html-source"; + src = pkgs.fetchFromGitHub { + owner = "bluelisp"; + repo = "closure-html"; + rev = "fee42604ae36884d2f7c5e8ffc3441fdb8ec77b7"; # 2017-04-19 + sha256 = "105vm29qnxh6zj3rh4jwpm8dyp3b9bsva64c8a78cr270p28d032"; + }; + + patches = [ + # delete unexported and unused double defun in sgml-dtd.lisp + # which reference undefined CL-USER:*HTML-DTD* (!) which + # unlike CLOSURE-HTML:*HTML-DTD* is not involved in the + # packages operation. + ./no-double-defun.patch + # Patches html-parser.lisp to look for the distributed + # dtd files and catalog in this source derivations out + # path in the nix store instead of the same directory + # relatively to the (built) system. + ./dtds-from-store.patch + ]; + + postPatch = '' + # Inject file which defines CLOSURE-HTML:*HTML-DTD* + # early in the package's build since SBCL otherwise + # fails due to the undefined variable. Need to inject + # this via postPatch since using a nix file results + # in failure to look up the file's true name which + # is done for … reasons, apparently. + cat > src/define-html-dtd.lisp << EOF + (in-package :closure-html) + (defvar *html-dtd*) + EOF + + # Substitute reference to @out@ of this source + # directory in this patched file. + substituteAllInPlace src/parse/html-parser.lisp + ''; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); +in + +depot.nix.buildLisp.library { + name = "closure-html"; + + srcs = getSrcs [ + "src/defpack.lisp" + "src/define-html-dtd.lisp" + "src/glisp/util.lisp" + "src/util/clex.lisp" + "src/util/lalr.lisp" + "src/net/mime.lisp" + "src/parse/pt.lisp" + "src/parse/sgml-dtd.lisp" + "src/parse/sgml-parse.lisp" + "src/parse/html-parser.lisp" + "src/parse/lhtml.lisp" + "src/parse/unparse.lisp" + "src/parse/documentation.lisp" + ]; + + deps = [ + depot.third_party.lisp.flexi-streams + depot.third_party.lisp.closure-common + ]; +} diff --git a/third_party/lisp/closure-html/dtds-from-store.patch b/third_party/lisp/closure-html/dtds-from-store.patch new file mode 100644 index 000000000000..a9ffd8085e89 --- /dev/null +++ b/third_party/lisp/closure-html/dtds-from-store.patch @@ -0,0 +1,16 @@ +diff --git a/src/parse/html-parser.lisp b/src/parse/html-parser.lisp +index 4e45b81..5025a26 100644 +--- a/src/parse/html-parser.lisp ++++ b/src/parse/html-parser.lisp +@@ -36,10 +36,7 @@ + (make-pathname + :name nil + :type nil +- :defaults (merge-pathnames +- "resources/" +- (asdf:component-relative-pathname +- (asdf:find-system :closure-html)))))) ++ :defaults "@out@/resources/"))) + (loop + :for (name . filename) + :in '(("-//W3O//DTD W3 HTML 3.0//EN" . "dtd/HTML-3.0") diff --git a/third_party/lisp/closure-html/no-double-defun.patch b/third_party/lisp/closure-html/no-double-defun.patch new file mode 100644 index 000000000000..ce7fb33abff1 --- /dev/null +++ b/third_party/lisp/closure-html/no-double-defun.patch @@ -0,0 +1,78 @@ +diff --git a/src/parse/sgml-dtd.lisp b/src/parse/sgml-dtd.lisp +index de774c0..dbee852 100644 +--- a/src/parse/sgml-dtd.lisp ++++ b/src/parse/sgml-dtd.lisp +@@ -624,73 +624,6 @@ + (return)))) + classes)) + +-;;;; ---------------------------------------------------------------------------------------------------- +-;;;; Compiled DTDs +-;;;; +- +-;; Since parsing and 'compiling' DTDs is slow, I'll provide for a way +-;; to (un)dump compiled DTD to stream. +- +-(defun dump-dtd (dtd sink) +- (let ((*print-pretty* nil) +- (*print-readably* t) +- (*print-circle* t)) +- (princ "#." sink) +- (prin1 +- `(MAKE-DTD :NAME ',(dtd-name dtd) +- :ELEMENTS (LET ((R (MAKE-HASH-TABLE :TEST #'EQ))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-elements dtd)) +- q)) +- R) +- :ENTITIES ',(dtd-entities dtd) +- :RESOLVE-INFO (LET ((R (MAKE-HASH-TABLE :TEST #'EQUAL))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-resolve-info dtd)) +- q)) +- R) +- ;; XXX surclusion-cache fehlt +- ) +- sink))) +- +-;;XXX +-(defun save-html-dtd () +- (with-open-file (sink "html-dtd.lisp" :direction :output :if-exists :new-version) +- (print `(in-package :sgml) sink) +- (let ((*package* (find-package :sgml))) +- (princ "(SETQ " sink) +- (prin1 'cl-user::*html-dtd* sink) +- (princ " '" sink) +- (dump-dtd cl-user::*html-dtd* sink) +- (princ ")" sink)))) +- +-;;; -------------------------------------------------------------------------------- +-;;; dumping DTDs +- +- +-(defun dump-dtd (dtd filename) +- (let ((*foo* dtd)) +- (declare (special *foo*)) +- (with-open-file (sink (merge-pathnames filename "*.lisp") +- :direction :output +- :if-exists :new-version) +- (format sink "(in-package :sgml)(locally (declare (special *foo*))(setq *foo* '#.*foo*))")) +- (compile-file (merge-pathnames filename "*.lisp")))) +- +-(defun undump-dtd (filename) +- (let (*foo*) +- (declare (special *foo*)) +- (load (compile-file-pathname (merge-pathnames filename "*.lisp")) +- :verbose nil +- :print nil) +- *foo*)) +- + (defmethod make-load-form ((self dtd) &optional env) + (declare (ignore env)) + `(make-dtd :name ',(dtd-name self) diff --git a/third_party/lisp/data-sift.nix b/third_party/lisp/data-sift.nix new file mode 100644 index 000000000000..18593421e8ed --- /dev/null +++ b/third_party/lisp/data-sift.nix @@ -0,0 +1,27 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "archimag"; + repo = "data-sift"; + rev = "fd617d8200cdcc1b87ecf45ab59bb38e8b16ef7e"; + sha256 = "1v7gf0x4ibjzp0c56n9m77hxdgwcm9356zlk5n4l3fx4i0hj6146"; + }; + +in depot.nix.buildLisp.library { + name = "data-sift"; + deps = with depot.third_party.lisp; [ + cl-ppcre + parse-number + alexandria + puri + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "packages.lisp" + "conditions.lisp" + "sift.lisp" + ]; + +} diff --git a/third_party/lisp/defclass-std.nix b/third_party/lisp/defclass-std.nix new file mode 100644 index 000000000000..781fd107f59d --- /dev/null +++ b/third_party/lisp/defclass-std.nix @@ -0,0 +1,21 @@ +# A shortcut macro to write DEFCLASS forms quickly +# Seems to be unmaintained (since early 2021) +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "EuAndreh"; + repo = "defclass-std"; + rev = "a4d32260a619eddf3a3e49df3af304f3c07ccec6"; + sha256 = "1c0ymb49wd205lzxmnmsrpqyv0pn61snn2xvsbk5iis135r4fr18"; + }; +in depot.nix.buildLisp.library { + name = "defclass-std"; + deps = with depot.third_party.lisp; [ + alexandria + anaphora + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "defclass-std.lisp" + ]; +} diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix new file mode 100644 index 000000000000..3757aad7b144 --- /dev/null +++ b/third_party/lisp/drakma.nix @@ -0,0 +1,39 @@ +# Drakma is an HTTP client for Common Lisp. +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "drakma"; + rev = "87feb02bef00b11a753d5fb21a5fec526b0d0bbb"; + sha256 = "01b80am2vrw94xmdj7f21qm7p5ys08mmpzv4nc4icql81hqr1w2m"; +}; +in depot.nix.buildLisp.library { + name = "drakma"; + deps = with depot.third_party.lisp; [ + chipz + chunga + cl-base64 + cl-plus-ssl + cl-ppcre + flexi-streams + puri + usocket + (depot.nix.buildLisp.bundled "asdf") + ]; + + 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" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/easy-routes.nix b/third_party/lisp/easy-routes.nix new file mode 100644 index 000000000000..93aed8a66765 --- /dev/null +++ b/third_party/lisp/easy-routes.nix @@ -0,0 +1,29 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "mmontone"; + repo = "easy-routes"; + rev = "dab613ff419a655036a00beecee026ab6e0ba430"; + sha256 = "06lnipwc6mmg0v5gybcnr7wn5xmn5xfd1gs19vbima777245bfka"; + }; + +in depot.nix.buildLisp.library { + name = "easy-routes"; + deps = with depot.third_party.lisp; [ + hunchentoot + routes + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "util.lisp" + "easy-routes.lisp" + "routes-map-printer.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/fiveam/.boring b/third_party/lisp/fiveam/.boring new file mode 100644 index 000000000000..662944f765b3 --- /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 000000000000..6f6559189f27 --- /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 000000000000..91adf85a5a64 --- /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 000000000000..32a205fa5f5a --- /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 000000000000..4236b93bc9c5 --- /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 + +{ depot, ... }: + +depot.nix.buildLisp.library { + name = "fiveam"; + + deps = with depot.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 000000000000..8144c94f020e --- /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 000000000000..7607e33372fd --- /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 000000000000..b3808c5cf04c --- /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 000000000000..fc4dc782e8cb --- /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 000000000000..015cdf45521a --- /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 000000000000..26e993304fd9 --- /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 000000000000..3279a9a4f7fc --- /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 000000000000..49e14bc8a880 --- /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 000000000000..89c522351504 --- /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 000000000000..4a1e6010dce5 --- /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 000000000000..8497a9d12ddc --- /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 000000000000..4a6f2fee9a0a --- /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 000000000000..49d552fa000e --- /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 000000000000..c949511a28cd --- /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 000000000000..ed1c565e7d4a --- /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 000000000000..e0e0284e6761 --- /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 000000000000..8cdf062f1cf2 --- /dev/null +++ b/third_party/lisp/flexi-streams.nix @@ -0,0 +1,34 @@ +# Flexible bivalent streams for Common Lisp +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/edicl/flexi-streams.git"; + rev = "0fd872ae32022e834ef861a67d86879cf33a6b64"; +}; +in depot.nix.buildLisp.library { + name = "flexi-streams"; + deps = [ depot.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/global-vars.nix b/third_party/lisp/global-vars.nix new file mode 100644 index 000000000000..2b4078f588cd --- /dev/null +++ b/third_party/lisp/global-vars.nix @@ -0,0 +1,14 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "lmj"; + repo = "global-vars"; + rev = "c749f32c9b606a1457daa47d59630708ac0c266e"; + sha256 = "06m3xc8l3pgsapl8fvsi9wf6y46zs75cp9zn7zh6dc65v4s5wz3d"; + }; + +in depot.nix.buildLisp.library { + name = "global-vars"; + srcs = [ "${src}/global-vars.lisp" ] ; +} diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix new file mode 100644 index 000000000000..24eae6a348cf --- /dev/null +++ b/third_party/lisp/hunchentoot.nix @@ -0,0 +1,65 @@ +# Hunchentoot is a web framework for Common Lisp. +{ depot, pkgs, ...}: + +let + src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "hunchentoot"; + rev = "585b45b6b873f2da421fdf456b61860ab5868207"; + sha256 = "13nazwix067mdclq9vgjhsi2vpr57a8dz51dd5d3h99ccsq4mik5"; + }; + url-rewrite = depot.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 depot.nix.buildLisp.library { + name = "hunchentoot"; + + deps = with depot.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" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/ironclad.nix b/third_party/lisp/ironclad.nix new file mode 100644 index 000000000000..cdd829924ee5 --- /dev/null +++ b/third_party/lisp/ironclad.nix @@ -0,0 +1,155 @@ +{ depot, pkgs, ...}: + +let + inherit (pkgs) runCommand; + inherit (depot.nix.buildLisp) bundled; + src = pkgs.fetchFromGitHub { + owner = "sharplispers"; + repo = "ironclad"; + rev = "c3aa33080621abc10fdb0f34acc4655cc4e982a6"; + sha256 = "0k4bib9mbrzalbl9ivkw4a7g4c7bbad1l5jw4pzkifqszy2swkr5"; + }; + + getSrc = f: "${src}/src/${f}"; + +in depot.nix.buildLisp.library { + name = "ironclad"; + + deps = with depot.third_party.lisp; [ + (bundled "asdf") + { sbcl = bundled "sb-rotate-byte"; } + { sbcl = bundled "sb-posix"; } + alexandria + bordeaux-threads + nibbles + ]; + + srcs = [ + { + # TODO(grfn): Figure out how to get this compiling with the assembly + # optimization eventually - see https://cl.tvl.fyi/c/depot/+/1333 + sbcl = runCommand "package.lisp" {} '' + substitute ${src}/src/package.lisp $out \ + --replace \#-ecl-bytecmp "" \ + --replace '(pushnew :ironclad-assembly *features*)' "" + ''; + default = getSrc "package.lisp"; + } + ] ++ map getSrc [ + "macro-utils.lisp" + ] ++ [ + { sbcl = getSrc "opt/sbcl/fndb.lisp"; } + { sbcl = getSrc "opt/sbcl/cpu-features.lisp"; } + { sbcl = getSrc "opt/sbcl/x86oid-vm.lisp"; } + + { ecl = getSrc "opt/ecl/c-functions.lisp"; } + + { ccl = getSrc "opt/ccl/x86oid-vm.lisp"; } + ] ++ map getSrc [ + + "common.lisp" + "conditions.lisp" + "generic.lisp" + "util.lisp" + + "ciphers/padding.lisp" + "ciphers/cipher.lisp" + "ciphers/chacha.lisp" + "ciphers/modes.lisp" + "ciphers/salsa20.lisp" + "ciphers/xchacha.lisp" + "ciphers/xsalsa20.lisp" + "ciphers/aes.lisp" + "ciphers/arcfour.lisp" + "ciphers/arcfour.lisp" + "ciphers/aria.lisp" + "ciphers/blowfish.lisp" + "ciphers/camellia.lisp" + "ciphers/cast5.lisp" + "ciphers/des.lisp" + "ciphers/idea.lisp" + "ciphers/keystream.lisp" + "ciphers/kalyna.lisp" + "ciphers/kuznyechik.lisp" + "ciphers/make-cipher.lisp" + "ciphers/misty1.lisp" + "ciphers/rc2.lisp" + "ciphers/rc5.lisp" + "ciphers/rc6.lisp" + "ciphers/seed.lisp" + "ciphers/serpent.lisp" + "ciphers/sm4.lisp" + "ciphers/sosemanuk.lisp" + "ciphers/square.lisp" + "ciphers/tea.lisp" + "ciphers/threefish.lisp" + "ciphers/twofish.lisp" + "ciphers/xor.lisp" + "ciphers/xtea.lisp" + + "digests/digest.lisp" + "digests/adler32.lisp" + "digests/blake2.lisp" + "digests/blake2s.lisp" + "digests/crc24.lisp" + "digests/crc32.lisp" + "digests/groestl.lisp" + "digests/jh.lisp" + "digests/kupyna.lisp" + "digests/md2.lisp" + "digests/md4.lisp" + "digests/md5.lisp" + "digests/md5-lispworks-int32.lisp" + "digests/ripemd-128.lisp" + "digests/ripemd-160.lisp" + "digests/sha1.lisp" + "digests/sha256.lisp" + "digests/sha3.lisp" + "digests/sha512.lisp" + "digests/skein.lisp" + "digests/sm3.lisp" + "digests/streebog.lisp" + "digests/tiger.lisp" + "digests/tree-hash.lisp" + "digests/whirlpool.lisp" + + "prng/prng.lisp" + "prng/generator.lisp" + "prng/fortuna.lisp" + "prng/os-prng.lisp" + + "math.lisp" + + "macs/mac.lisp" + "macs/blake2-mac.lisp" + "macs/blake2s-mac.lisp" + "macs/cmac.lisp" + "macs/hmac.lisp" + "macs/gmac.lisp" + "macs/poly1305.lisp" + "macs/siphash.lisp" + "macs/skein-mac.lisp" + + "kdf/kdf-common.lisp" + "kdf/argon2.lisp" + "kdf/password-hash.lisp" + "kdf/pkcs5.lisp" + "kdf/scrypt.lisp" + "kdf/hmac.lisp" + + "aead/aead.lisp" + "aead/eax.lisp" + "aead/etm.lisp" + "aead/gcm.lisp" + + "public-key/public-key.lisp" + "public-key/curve25519.lisp" + "public-key/curve448.lisp" + "public-key/dsa.lisp" + "public-key/ed25519.lisp" + "public-key/ed448.lisp" + "public-key/elgamal.lisp" + "public-key/pkcs1.lisp" + "public-key/rsa.lisp" + ]; +} diff --git a/third_party/lisp/iterate.nix b/third_party/lisp/iterate.nix new file mode 100644 index 000000000000..5875be8d5c88 --- /dev/null +++ b/third_party/lisp/iterate.nix @@ -0,0 +1,15 @@ +# iterate is an iteration construct for Common Lisp, similar to the +# LOOP macro. +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://gitlab.common-lisp.net/iterate/iterate.git"; + rev = "c24f6715bb3b962499bb4643636baaac2df4a957"; # 2021-05-23, 1.5.3 +}; +in depot.nix.buildLisp.library { + name = "iterate"; + srcs = [ + "${src}/package.lisp" + "${src}/iterate.lisp" + ]; +} diff --git a/third_party/lisp/lass.nix b/third_party/lisp/lass.nix new file mode 100644 index 000000000000..457e25c7e532 --- /dev/null +++ b/third_party/lisp/lass.nix @@ -0,0 +1,34 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "Shinmera"; + repo = "LASS"; + rev = "f51b9e941ee0a2a1f76ba814dcef22f9fb5f69bf"; + sha256 = "11mxzyx34ynsfsrs8pgrarqi9s442vkpmh7kdpzvarhj7i97g8yx"; + }; + +in depot.nix.buildLisp.library { + name = "lass"; + + deps = with depot.third_party.lisp; [ + trivial-indent + trivial-mimes + physical-quantities + parse-float + cl-base64 + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "readable-list.lisp" + "compiler.lisp" + "property-funcs.lisp" + "writer.lisp" + "lass.lisp" + "special.lisp" + "units.lisp" + "asdf.lisp" + ]; +} diff --git a/third_party/lisp/let-plus.nix b/third_party/lisp/let-plus.nix deleted file mode 100644 index a750443fd1c8..000000000000 --- a/third_party/lisp/let-plus.nix +++ /dev/null @@ -1,19 +0,0 @@ -{ depot, briefcase, ... }: - -let - src = builtins.fetchGit { - url = "https://github.com/tpapp/let-plus.git"; - rev = "7cf18b29ed0fe9c667a9a6a101b08ab9661a59e9"; - }; -in depot.nix.buildLisp.library { - name = "let-plus"; - deps = [ - depot.third_party.lisp.alexandria - briefcase.third_party.lisp.anaphora - ]; - srcs = [ - "${src}/package.lisp" - "${src}/let-plus.lisp" - "${src}/extensions.lisp" - ]; -} diff --git a/third_party/lisp/linear-programming.nix b/third_party/lisp/linear-programming.nix deleted file mode 100644 index fc95787a1d85..000000000000 --- a/third_party/lisp/linear-programming.nix +++ /dev/null @@ -1,26 +0,0 @@ -{ depot, ... }: - -let - src = builtins.fetchGit { - url = "https://github.com/neil-lindquist/linear-programming.git"; - rev = "8c8d55e7584773b90c4ba4b225c5f2008f4c474a"; - }; -in depot.nix.buildLisp.library { - name = "linear-programming"; - deps = [ - (depot.nix.buildLisp.bundled "uiop") - depot.third_party.lisp.iterate - depot.third_party.lisp.alexandria - ]; - srcs = [ - "${src}/src/conditions.lisp" - "${src}/src/expressions.lisp" - "${src}/src/simplex.lisp" - "${src}/src/system-info.lisp" - "${src}/src/utils.lisp" - "${src}/src/problem.lisp" - "${src}/src/solver.lisp" - "${src}/src/external-formats.lisp" - "${src}/src/all.lisp" - ]; -} diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix new file mode 100644 index 000000000000..3e7a43b8ac67 --- /dev/null +++ b/third_party/lisp/lisp-binary.nix @@ -0,0 +1,35 @@ +# A library to easily read and write complex binary formats. +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "j3pic"; + repo = "lisp-binary"; + rev = "052df578900dea59bf951e0a6749281fa73432e4"; + sha256 = "1i1s5g01aimfq6lndcl1pnw7ly5hdh0wmjp2dj9cjjwbkz9lnwcf"; +}; +in depot.nix.buildLisp.library { + name = "lisp-binary"; + + deps = with depot.third_party.lisp; [ + cffi + quasiquote_2 + moptilities + flexi-streams + closer-mop + ]; + + srcs = map (f: src + ("/" + f)) [ + "utils.lisp" + "integer.lisp" + "float.lisp" + "simple-bit-stream.lisp" + "reverse-stream.lisp" + "binary-1.lisp" + "binary-2.lisp" + "types.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix new file mode 100644 index 000000000000..65fb9c37fbf2 --- /dev/null +++ b/third_party/lisp/local-time.nix @@ -0,0 +1,18 @@ +# Library for manipulating dates & times +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "dlowe-net"; + repo = "local-time"; + rev = "dc54f61415c76ee755a6f69d4154a3a282f2789f"; + sha256 = "1l9v07ghx7g9p2gp003fki4j8bsa1w2gbm40qc41i94mdzikc0ry"; +}; +in depot.nix.buildLisp.library { + name = "local-time"; + deps = [ depot.third_party.lisp.cl-fad ]; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/local-time.lisp" + ]; +} diff --git a/third_party/lisp/marshal.nix b/third_party/lisp/marshal.nix new file mode 100644 index 000000000000..711e6e082d61 --- /dev/null +++ b/third_party/lisp/marshal.nix @@ -0,0 +1,20 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "wlbr"; + repo = "cl-marshal"; + rev = "eff1b15f2b0af2f26f71ad6a4dd5c4beab9299ec"; + sha256 = "08qs6fhk38xpkkjkpcj92mxx0lgy4ygrbbzrmnivdx281syr0gwh"; + }; + +in depot.nix.buildLisp.library { + name = "marshal"; + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "serialization-format.lisp" + "coding-idiom.lisp" + "marshal.lisp" + "unmarshal.lisp" + ]; +} diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix new file mode 100644 index 000000000000..ef265d5b6e8f --- /dev/null +++ b/third_party/lisp/md5.nix @@ -0,0 +1,21 @@ +# MD5 hash implementation +{ depot, pkgs, ... }: + +with depot.nix; + +let src = pkgs.fetchFromGitHub { + owner = "pmai"; + repo = "md5"; + rev = "b1412600f60d526ee34a7ba1596ec483da7894ab"; + sha256 = "0lzip6b6xg7gd70xl1xmqp24fvxqj6ywjnz9lmx7988zpj20nhl2"; +}; +in buildLisp.library { + name = "md5"; + deps = [ + { + sbcl = buildLisp.bundled "sb-rotate-byte"; + default = depot.third_party.lisp.flexi-streams; + } + ]; + srcs = [ (src + "/md5.lisp") ]; +} diff --git a/third_party/lisp/mime4cl/.skip-subtree b/third_party/lisp/mime4cl/.skip-subtree new file mode 100644 index 000000000000..5051f60d6b86 --- /dev/null +++ b/third_party/lisp/mime4cl/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS new file mode 100644 index 000000000000..f16dd105d761 --- /dev/null +++ b/third_party/lisp/mime4cl/OWNERS @@ -0,0 +1,3 @@ +inherited: true +owners: + - sterni diff --git a/third_party/lisp/mime4cl/README b/third_party/lisp/mime4cl/README new file mode 100644 index 000000000000..73f0efbda9d5 --- /dev/null +++ b/third_party/lisp/mime4cl/README @@ -0,0 +1,7 @@ +MIME4CL is a Common Lisp library for dealing with MIME messages. +It has originally been written by Walter C. Pelissero and vendored +into depot as upstream has become inactive and provides no repo +of any kind. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#mime4cl +Vendored Tarball: http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp new file mode 100644 index 000000000000..9a3bec9b2078 --- /dev/null +++ b/third_party/lisp/mime4cl/address.lisp @@ -0,0 +1,301 @@ +;;; address.lisp --- e-mail address parser + +;;; Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +#+cmu (ext:file-comment "$Module: address.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Although not MIME specific, this parser is often useful together +;;; with the MIME primitives. It should be able to parse the address +;;; syntax described in RFC2822 excluding the obsolete syntax (see +;;; RFC822). Have a look at the test suite to get an idea of what +;;; kind of addresses it can parse. + +(in-package :mime4cl) + +(defstruct (mailbox (:conc-name mbx-)) + description + user + host + domain) + +(defstruct (mailbox-group (:conc-name mbxg-)) + name + mailboxes) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun write-mailbox-domain-name (addr &optional (stream *standard-output*)) + (when (eq :internet (mbx-domain addr)) + (write-char #\[ stream)) + (write-string (mbx-host addr) stream) + (when (eq :internet (mbx-domain addr)) + (write-char #\] stream)) + (when (stringp (mbx-domain addr)) + (write-char #\. stream) + (write-string (mbx-domain addr) stream))) + +(defun write-mailbox-address (addr &optional (stream *standard-output*)) + (write-string (mbx-user addr) stream) + (when (mbx-host addr) + (write-char #\@ stream) + (write-mailbox-domain-name addr stream))) + +(defmethod mbx-domain-name ((MBX mailbox)) + "Return the complete domain name string of MBX, in the form +\"host.domain\"." + (with-output-to-string (out) + (write-mailbox-domain-name mbx out))) + +(defmethod mbx-address ((mbx mailbox)) + "Return the e-mail address string of MBX, in the form +\"user@host.domain\"." + (with-output-to-string (out) + (write-mailbox-address mbx out))) + +(defun write-mailbox (addr &optional (stream *standard-output*)) + (awhen (mbx-description addr) + (write it :stream stream :readably t) + (write-string " <" stream)) + (write-mailbox-address addr stream) + (awhen (mbx-description addr) + (write-char #\> stream))) + +(defun write-mailbox-group (grp &optional (stream *standard-output*)) + (write-string (mbxg-name grp) stream) + (write-string ": " stream) + (loop + for mailboxes on (mbxg-mailboxes grp) + for mailbox = (car mailboxes) + do (write-mailbox mailbox stream) + unless (endp (cdr mailboxes)) + do (write-string ", " stream)) + (write-char #\; stream)) + +(defmethod print-object ((mbx mailbox) stream) + (if (or *print-readably* *print-escape*) + (call-next-method) + (write-mailbox mbx stream))) + +(defmethod print-object ((grp mailbox-group) stream) + (if (or *print-readably* *print-escape*) + (call-next-method) + (write-mailbox-group grp stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun parser-make-mailbox (description address-list) + (make-mailbox :description description + :user (car address-list) + :host (cadr address-list) + :domain (when (cddr address-list) + (string-concat (cddr address-list) ".")))) + + +(defun populate-grammar () + (defrule address-list + := (+ address ",")) + + (defrule address + := mailbox + := group) + + (defrule mailbox + := display-name? angle-addr comment? + :reduce (parser-make-mailbox (or display-name comment) angle-addr) + := addr-spec comment? + :reduce (parser-make-mailbox comment addr-spec)) + + (defrule angle-addr + := "<" addr-spec ">") + + (defrule group + := display-name ":" mailbox-list ";" + :reduce (make-mailbox-group :name display-name :mailboxes mailbox-list)) + + (defrule display-name + := phrase + :reduce (string-concat phrase " ")) + + (defrule phrase + := word+) + + (defrule word + := atext + := string) + + (defrule mailbox-list + := (+ mailbox ",")) + + (defrule addr-spec + := local-part "@" domain :reduce (cons local-part domain)) + + (defrule local-part + := dot-atom :reduce (string-concat dot-atom ".") + := string) + + (defrule domain + := dot-atom + := domain-literal :reduce (list domain-literal :internet)) + + ;; actually, according to the RFC, dot-atoms don't allow spaces in + ;; between but these rules do + (defrule dot-atom + := (+ atom ".")) + + (defrule atom + := atext+ + :reduce (apply #'concatenate 'string atext))) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (when npg::*debug* t))) + (reset-grammar) + (format t "~&creating e-mail address grammar...~%") + (populate-grammar) + (let ((grammar (npg:generate-grammar #'string=))) + (reset-grammar) + (npg:print-grammar-figures grammar) + grammar))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The lexical analyser + +(defstruct cursor + stream + (position 0)) + +(defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\)) + (labels ((collect () + (with-output-to-string (out) + (loop + for c = (read-char stream nil) + while (and c (not (char= c end-char))) + do (cond ((char= c escape-char) + (awhen (read-char stream nil) + (write-char it out))) + ((and nesting-start-char + (char= c nesting-start-char)) + (write-char nesting-start-char out) + (write-string (collect) out) + (write-char end-char out)) + (t (write-char c out))))))) + (collect))) + + +(defun read-string (cursor) + (make-token :type 'string + :value (read-delimited-string (cursor-stream cursor) #\") + :position (incf (cursor-position cursor)))) + +(defun read-domain-literal (cursor) + (make-token :type 'domain-literal + :value (read-delimited-string (cursor-stream cursor) #\]) + :position (incf (cursor-position cursor)))) + +(defun read-comment (cursor) + (make-token :type 'comment + :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\() + :position (incf (cursor-position cursor)))) + +(declaim (inline atom-component-p)) +(defun atom-component-p (c) + (declare (type character c)) + (not (find c " ()\"[]@.<>:;,"))) + +(defun read-atext (first-character cursor) + (be string (with-output-to-string (out) + (write-char first-character out) + (loop + for c = (read-char (cursor-stream cursor) nil) + while (and c (atom-component-p c)) + do (write-char c out) + finally (when c + (unread-char c (cursor-stream cursor))))) + (make-token :type 'atext + :value string + :position (incf (cursor-position cursor))))) + +(defmethod read-next-tokens ((cursor cursor)) + (flet ((make-keyword (c) + (make-token :type 'keyword + :value (string c) + :position (incf (cursor-position cursor))))) + (be in (cursor-stream cursor) + (loop + for c = (read-char in nil) + while c + unless (whitespace-p c) + return (list + (cond ((char= #\( c) + (read-comment cursor)) + ((char= #\" c) + (read-string cursor)) + ((char= #\[ c) + (read-domain-literal cursor)) + ((find c "@.<>:;,") + (make-keyword c)) + (t + ;; anything else is considered a text atom even + ;; though it's just a single character + (read-atext c cursor)))))))) + +(defun analyse-string (string) + "Return the list of tokens produced by a lexical analysis of +STRING. These are the tokens that would be seen by the parser." + (with-input-from-string (stream string) + (be cursor (make-cursor :stream stream) + (loop + for tokens = (read-next-tokens cursor) + until (endp tokens) + append tokens)))) + +(defun mailboxes-only (list-of-mailboxes-and-groups) + "Return a flat list of MAILBOX-ADDRESSes from +LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned +by PARSE-ADDRESSES. This turns out to be useful when your +program is not interested in mailbox groups and expects the user +addresses only." + (mapcan #'(lambda (mbx) + (if (typep mbx 'mailbox-group) + (mbxg-mailboxes mbx) + (list mbx))) + list-of-mailboxes-and-groups)) + +(defun parse-addresses (string &key no-groups) + "Parse STRING and return a list of MAILBOX-ADDRESSes or +MAILBOX-GROUPs. If STRING is unparsable return NIL. If +NO-GROUPS is true, return a flat list of mailboxes throwing away +the group containers, if any." + (be grammar (force define-grammar) + (with-input-from-string (stream string) + (be* cursor (make-cursor :stream stream) + mailboxes (ignore-errors ; ignore parsing errors + (parse grammar 'address-list cursor)) + (if no-groups + (mailboxes-only mailboxes) + mailboxes))))) + +(defun debug-addresses (string) + "More or less like PARSE-ADDRESSES, but don't ignore parsing errors." + (be grammar (force define-grammar) + (with-input-from-string (stream string) + (be cursor (make-cursor :stream stream) + (parse grammar 'address-list cursor))))) + diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix new file mode 100644 index 000000000000..5165774074c1 --- /dev/null +++ b/third_party/lisp/mime4cl/default.nix @@ -0,0 +1,48 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "mime4cl"; + + deps = [ + depot.third_party.lisp.sclf + depot.third_party.lisp.npg + ]; + + srcs = [ + ./package.lisp + ./endec.lisp + ./streams.lisp + ./mime.lisp + ./address.lisp + ]; + + tests = { + name = "mime4cl-tests"; + + srcs = [ + ./test/rt.lisp + ./test/package.lisp + (pkgs.writeText "nix-samples.lisp" '' + (in-package :mime4cl-tests) + + ;; missing from the tarball completely + (defvar *samples-directory* (pathname "/this/does/not/exist")) + ;; override auto discovery which doesn't work in store + (defvar *sample1-file* (pathname "${./test/sample1.msg}")) + '') + ./test/endec.lisp + ./test/address.lisp + ./test/mime.lisp + ]; + + expression = "(rtest:do-tests)"; + }; + + # limited by sclf + brokenOn = [ + "ccl" + "ecl" + ]; +} diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp new file mode 100644 index 000000000000..f63eb3c22e1d --- /dev/null +++ b/third_party/lisp/mime4cl/endec.lisp @@ -0,0 +1,683 @@ +;;; endec.lisp --- encoder/decoder functions + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + + +(in-package :mime4cl) + + +;; Thank you SBCL for rendering constants totally useless! +(defparameter +base64-encode-table+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") + +(defparameter +base64-decode-table+ + (let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65))) + (dotimes (i 64) + (setf (aref da (char-code (char +base64-encode-table+ i))) i)) + da)) + +(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+) + (type simple-string +base64-encode-table+)) + +(defvar *base64-line-length* 76 + "Maximum length of the encoded base64 line. NIL means it can +be of unlimited length \(no line breaks will be done by the +encoding function).") + +(defvar *quoted-printable-line-length* 72 + "Maximum length of the encoded quoted printable line. NIL +means it can be of unlimited length \(no line breaks will be done +by the encoding function).") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass decoder () + ((input-function :initarg :input-function + :reader decoder-input-function + :type function + :documentation + "Function is called repeatedly by the decoder methods to get the next character. +It should return a character os NIL (indicating EOF).")) + (:documentation + "Abstract base class for decoders.")) + +(defclass parsing-decoder (decoder) + ((parser-errors :initform nil + :initarg :parser-errors + :reader decoder-parser-errors + :type boolean)) + (:documentation + "Abstract base class for decoders that do parsing.")) + +(defclass encoder () + ((output-function :initarg :output-function + :reader encoder-output-function + :type function + :documentation + "Function is called repeatedly by the encoder methods to output a character. +It should expect a character as its only argument.")) + (:documentation + "Abstract base class for encoders.")) + +(defclass line-encoder (encoder) + ((column :initform 0 + :type fixnum) + (line-length :initarg :line-length + :initform nil + :reader encoder-line-length + :type (or fixnum null))) + (:documentation + "Abstract base class for line encoders.")) + +(defclass 8bit-decoder (decoder) + () + (:documentation + "Class for decoders that do nothing.")) + +(defclass 8bit-encoder (encoder) + () + (:documentation + "Class for encoders that do nothing.")) + +(defclass 7bit-decoder (decoder) + () + (:documentation + "Class for decoders that do nothing.")) + +(defclass 7bit-encoder (encoder) + () + (:documentation + "Class for encoders that do nothing.")) + +(defclass byte-decoder (decoder) + () + (:documentation + "Class for decoders that turns chars to bytes.")) + +(defclass byte-encoder (encoder) + () + (:documentation + "Class for encoders that turns bytes to chars.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric encoder-write-byte (encoder byte)) +(defgeneric encoder-finish-output (encoder)) +(defgeneric decoder-read-byte (decoder)) + +(defmethod encoder-finish-output ((encoder encoder)) + (values)) + +(defmethod encoder-write-byte ((encoder 8bit-encoder) byte) + (funcall (slot-value encoder 'output-function) + (code-char byte)) + (values)) + +(defmethod decoder-read-byte ((decoder 8bit-decoder)) + (awhen (funcall (slot-value decoder 'input-function)) + (char-code it))) + +(defmethod encoder-write-byte ((encoder 7bit-encoder) byte) + (funcall (slot-value encoder 'output-function) + (code-char (logand #x7F byte))) + (values)) + +(defmethod decoder-read-byte ((decoder 7bit-decoder)) + (awhen (funcall (slot-value decoder 'input-function)) + (logand #x7F (char-code it)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence))) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type fixnum start end) + (type vector sequence)) + (loop + for i fixnum from start below end + for byte = (decoder-read-byte decoder) + while byte + do (setf (aref sequence i) byte) + finally (return i))) + +(defun decoder-read-line (decoder) + (with-output-to-string (str) + (loop + for byte = (decoder-read-byte decoder) + unless byte + do (return-from decoder-read-line nil) + do (be c (code-char byte) + (cond ((char= c #\return) + ;; skip the newline + (decoder-read-byte decoder) + (return nil)) + ((char= c #\newline) + ;; the #\return was missing + (return nil)) + (t (write-char c str))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline parse-hex)) +(defun parse-hex (c1 c2) + "Parse two characters as hexadecimal and return their combined +value." + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type character c1 c2)) + (flet ((digit-value (char) + (or (position char "0123456789ABCDEF") + (return-from parse-hex nil)))) + (+ (* 16 (digit-value c1)) + (digit-value c2)))) + +(defclass quoted-printable-decoder (parsing-decoder) + ((saved-bytes :initform (make-queue)))) + +(defmethod decoder-read-byte ((decoder quoted-printable-decoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (input-function saved-bytes parser-errors) decoder + (declare (type function input-function)) + (labels ((saveb (b) + (queue-append saved-bytes b) + (values)) + (save (c) + (saveb (char-code c))) + (push-next () + (be c (funcall input-function) + (declare (type (or null character) c)) + (cond ((not c)) + ((or (char= c #\space) + (char= c #\tab)) + (save c) + (push-next)) + ((char= c #\=) + (be c1 (funcall input-function) + (cond ((not c1) + (save #\=)) + ((char= c1 #\return) + ;; soft line break: skip the next + ;; character which we assume to be a + ;; newline (pity if it isn't) + (funcall input-function) + (push-next)) + ((char= c1 #\newline) + ;; soft line break: the #\return is + ;; missing, but we are tolerant + (push-next)) + (t + ;; hexadecimal sequence: get the 2nd digit + (be c2 (funcall input-function) + (if c2 + (aif (parse-hex c1 c2) + (saveb it) + (if parser-errors + (error "invalid hex sequence ~A~A" c1 c2) + (progn + (save #\=) + (save c1) + (save c2)))) + (progn + (save c) + (save c1)))))))) + (t + (save c)))))) + (or (queue-pop saved-bytes) + (progn + (push-next) + (queue-pop saved-bytes)))))) + +(defmacro make-encoder-loop (encoder-class input-form output-form) + (with-gensyms (encoder byte) + `(loop + with ,encoder = (make-instance ',encoder-class + :output-function #'(lambda (char) ,output-form)) + for ,byte = ,input-form + while ,byte + do (encoder-write-byte ,encoder ,byte) + finally (encoder-finish-output ,encoder)))) + +(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors) + (with-gensyms (decoder) + `(loop + with ,decoder = (make-instance ',decoder-class + :input-function #'(lambda () ,input-form) + :parser-errors ,parser-errors) + for byte = (decoder-read-byte ,decoder) + while byte + do ,output-form))) + +(defun decode-quoted-printable-stream (in out &key parser-errors) + "Read from stream IN a quoted printable text and write to +binary output OUT the decoded stream of bytes." + (make-decoder-loop quoted-printable-decoder + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) + +(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors) + "Decode the character stream STREAM and return a sequence of bytes." + (with-gensyms (output-sequence) + `(be ,output-sequence (make-array 0 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t) + (make-decoder-loop ,decoder-class ,input-form + (vector-push-extend byte ,output-sequence) + :parser-errors ,parser-errors) + ,output-sequence))) + +(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors) + "Read from STREAM a quoted printable text and return a vector of +bytes." + (make-stream-to-sequence-decoder quoted-printable-decoder + (read-char stream nil) + :parser-errors parser-errors)) + +(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors) + "Decode STRING as quoted printable sequence of characters and +return a decoded sequence of bytes." + (with-input-from-string (in string :start start :end end) + (decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors))) + +(defclass quoted-printable-encoder (line-encoder) + ((line-length :initform *quoted-printable-line-length* + :type (or fixnum null)) + (pending-space :initform nil + :type boolean))) + +(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type (unsigned-byte 8) byte)) + (with-slots (output-function column pending-space line-length) encoder + (declare (type function output-function) + (type fixnum column) + (type (or fixnum null) line-length) + (type boolean pending-space)) + (labels ((out (c) + (funcall output-function c) + (values)) + (outs (str) + (declare (type simple-string str)) + (loop + for c across str + do (out c)) + (values)) + (out2hex (x) + (declare (type fixnum x)) + (multiple-value-bind (a b) (truncate x 16) + (out (digit-char a 16)) + (out (digit-char b 16))))) + (cond ((= byte #.(char-code #\newline)) + (when pending-space + (outs "=20") + (setf pending-space nil)) + (out #\newline) + (setf column 0)) + ((= byte #.(char-code #\space)) + (if pending-space + (progn + (out #\space) + (f++ column)) + (setf pending-space t))) + (t + (when pending-space + (out #\space) + (f++ column) + (setf pending-space nil)) + (cond ((or (< byte 32) + (= byte #.(char-code #\=)) + (> byte 126)) + (out #\=) + (out2hex byte) + (f++ column 3)) + (t + (out (code-char byte)) + (f++ column))))) + (when (and line-length + (>= column line-length)) + ;; soft line break + (outs #.(coerce '(#\= #\newline) 'string)) + (setf column 0))))) + +(defmethod encoder-finish-output ((encoder quoted-printable-encoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (pending-space output-function) encoder + (declare (type boolean pending-space) + (type function output-function)) + (when pending-space + (flet ((outs (s) + (declare (type simple-string s)) + (loop + for c across s + do (funcall output-function c)))) + (setf pending-space nil) + (outs "=20"))))) + +(defun encode-quoted-printable-stream (in out) + "Read from IN a stream of bytes and write to OUT a stream of +characters quoted printables encoded." + (make-encoder-loop quoted-printable-encoder + (read-byte in nil) + (write-char char out))) + +(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE and write to STREAM a +quoted printable sequence of characters." + (be i start + (make-encoder-loop quoted-printable-encoder + (when (< i end) + (prog1 (elt sequence i) + (f++ i))) + (write-char char stream)))) + +(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE into a quoted printable +string and return it." + (with-output-to-string (out) + (encode-quoted-printable-sequence-to-stream sequence out :start start :end end))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass base64-encoder (line-encoder) + ((line-length :initform *base64-line-length*) + (bitstore :initform 0 + :type fixnum) + (bytecount :initform 0 + :type fixnum)) + (:documentation + "Class for Base64 encoder output streams.")) + + +(eval-when (:load-toplevel :compile-toplevel) + (unless (> most-positive-fixnum (expt 2 (* 8 3))))) + +(macrolet ((with-encoder (encoder &body forms) + `(with-slots (bitstore line-length column bytecount output-function) ,encoder + (declare (type fixnum column) + (type fixnum bitstore bytecount) + (type (or fixnum null) line-length) + (type function output-function)) + (labels ((emitr (i b) + (declare (type fixnum i b)) + (unless (zerop i) + (emitr (1- i) (ash b -6))) + (emitc + (char +base64-encode-table+ (logand b #x3F))) + (values)) + (out (c) + (funcall output-function c)) + (eol () + (progn + (out #\return) + (out #\newline))) + (emitc (char) + (out char) + (f++ column) + (when (and line-length + (>= column line-length)) + (setf column 0) + (eol)))) + (declare (inline out eol emitc) + (ignorable (function emitr) (function out) (function eol) (function emitc))) + ,@forms)))) + ;; For this function to work correctly, the FIXNUM must be at least + ;; 24 bits. + (defmethod encoder-write-byte ((encoder base64-encoder) byte) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type (unsigned-byte 8) byte)) + (with-encoder encoder + (setf bitstore (logior byte (the fixnum (ash bitstore 8)))) + (f++ bytecount) + (when (= 3 bytecount) + (emitr 3 bitstore) + (setf bitstore 0 + bytecount 0))) + (values)) + + (defmethod encoder-finish-output ((encoder base64-encoder)) + (with-encoder encoder + (unless (zerop bytecount) + (multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6) + (setf bitstore (ash bitstore (- 6 rest))) + (emitr saved6 bitstore) + (dotimes (x (- 3 saved6)) + (emitc #\=)))) + (when (and line-length + (not (zerop column))) + (eol))) + (values))) + +(defun encode-base64-stream (in out) + "Read a byte stream from IN and write to OUT the encoded Base64 +character stream." + (make-encoder-loop base64-encoder (read-byte in nil) + (write-char char out))) + +(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE and write to STREAM the +Base64 character sequence." + (be i start + (make-encoder-loop base64-encoder + (when (< i end) + (prog1 (elt sequence i) + (incf i))) + (write-char char stream)))) + +(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE into a Base64 string and +return it." + (with-output-to-string (out) + (encode-base64-sequence-to-stream sequence out :start start :end end))) + +(defclass base64-decoder (parsing-decoder) + ((bitstore :initform 0 + :type fixnum) + (bytecount :initform 0 :type fixnum)) + (:documentation + "Class for Base64 decoder input streams.")) + +(defmethod decoder-read-byte ((decoder base64-decoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (bitstore bytecount input-function) decoder + (declare (type fixnum bitstore bytecount) + (type function input-function)) + (labels ((in6 () + (loop + for c = (funcall input-function) + when (or (not c) (char= #\= c)) + do (return-from decoder-read-byte nil) + do (be sextet (aref +base64-decode-table+ (char-code c)) + (unless (= sextet 65) ; ignore unrecognised characters + (return sextet))))) + (push6 (sextet) + (declare (type fixnum sextet)) + (setf bitstore + (logior sextet (the fixnum (ash bitstore 6)))))) + (case bytecount + (0 + (setf bitstore (in6)) + (push6 (in6)) + (setf bytecount 1) + (ash bitstore -4)) + (1 + (push6 (in6)) + (setf bytecount 2) + (logand #xFF (ash bitstore -2))) + (2 + (push6 (in6)) + (setf bytecount 0) + (logand #xFF bitstore)))))) + +(defun decode-base64-stream (in out &key parser-errors) + "Read from IN a stream of characters Base64 encoded and write +to OUT a stream of decoded bytes." + (make-decoder-loop base64-decoder + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) + +(defun decode-base64-stream-to-sequence (stream &key parser-errors) + (make-stream-to-sequence-decoder base64-decoder + (read-char stream nil) + :parser-errors parser-errors)) + +(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors) + (with-input-from-string (in string :start start :end end) + (decode-base64-stream-to-sequence in :parser-errors parser-errors))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun dump-stream-binary (in out) + "Write content of IN character stream to OUT binary stream." + (loop + for c = (read-char in nil) + while c + do (write-byte (char-code c) out))) + +(defun decode-stream (in out encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-stream in out + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-stream in out + :parser-errors parser-errors-p)) + (otherwise + (dump-stream-binary in out)))) + +(defun decode-string (string encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-string string + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-string string + :parser-errors parser-errors-p)) + (otherwise + (map '(vector (unsigned-byte 8)) #'char-code string)))) + +(defun decode-stream-to-sequence (stream encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-stream-to-sequence stream + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-stream-to-sequence stream + :parser-errors parser-errors-p)) + (otherwise + (loop + with output-sequence = (make-array 0 :fill-pointer 0 + :element-type '(unsigned-byte 8) + :adjustable t) + for c = (read-char stream nil) + while c + do (vector-push-extend (char-code c) output-sequence) + finally (return output-sequence))))) + +(defun encode-stream (in out encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-stream in out)) + (:base64 + (encode-base64-stream in out)) + (otherwise + (loop + for byte = (read-byte in nil) + while byte + do (write-char (code-char byte) out))))) + +(defun encode-sequence-to-stream (sequence out encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-sequence-to-stream sequence out)) + (:base64 + (encode-base64-sequence-to-stream sequence out)) + (otherwise + (loop + for byte across sequence + do (write-char (code-char byte) out))))) + +(defun encode-sequence (sequence encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-sequence sequence)) + (:base64 + (encode-base64-sequence sequence)) + (otherwise + (map 'string #'code-char sequence)))) + +;; This is similar to decode-quoted-printable-string but #\_ is used +;; instead of space +(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string))) + "Decode a string encoded according to the quoted printable +method of RFC2047 and return a sequence of bytes." + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type simple-string string)) + (loop + with output-sequence = (make-array (length string) + :element-type '(unsigned-byte 8) + :fill-pointer 0) + for i fixnum from start by 1 below end + for c = (char string i) + do (case c + (#\= + (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i))) + ;; the char code was malformed + #.(char-code #\?)) + output-sequence) + (f++ i 2)) + (#\_ (vector-push-extend #.(char-code #\space) output-sequence)) + (otherwise + (vector-push-extend (char-code c) output-sequence))) + finally (return output-sequence))) + +(defun decode-RFC2047-string (encoding string &key (start 0) (end (length string))) + "Decode STRING according to RFC2047 and return a sequence of +bytes." + (gcase (encoding string-equal) + ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end)) + ("B" (decode-base64-string string :start start :end end)) + (t string))) + +(defun parse-RFC2047-text (text) + "Parse the string TEXT according to RFC2047 rules and return a list +of pairs and strings. The strings are the bits interposed between the +actually encoded text. The pairs are composed of: a decoded byte +sequence, a charset string indicating the original coding." + (loop + with result = '() + with previous-end = 0 + for start = (search "=?" text :start2 previous-end) + while start + for first-? = (position #\? text :start (+ 2 start)) + while first-? + for second-? = (position #\? text :start (1+ first-?)) + while second-? + for end = (search "?=" text :start2 (1+ second-?)) + while end + do (let ((charset (string-upcase (subseq text (+ 2 start) first-?))) + (encoding (subseq text (1+ first-?) second-?))) + (unless (= previous-end start) + (push (subseq text previous-end start) + result)) + (setf previous-end (+ end 2)) + (push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end) + charset) + result)) + finally (unless (= previous-end (length text)) + (push (subseq text previous-end (length text)) + result)) + (return (nreverse result)))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp new file mode 100644 index 000000000000..e35ae6bea547 --- /dev/null +++ b/third_party/lisp/mime4cl/mime.lisp @@ -0,0 +1,1061 @@ +;;; mime4cl.lisp --- MIME primitives for Common Lisp + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl) + +(defclass mime-part () + ((subtype + :type (or string null) + :initarg :subtype + :accessor mime-subtype + ;; some mime types don't require a subtype + :initform nil) + (type-parameters + :type list + :initarg :type-parameters + :initform '() + :accessor mime-type-parameters) + (version + :type (or string null) + :initarg :mime-version + :initform "1.0" + :accessor mime-version) + (id + :initform nil + :initarg :id + :reader mime-id) + (description + :initform nil + :initarg :description + :accessor mime-description) + (encoding + :initform :7bit + :initarg :encoding + :reader mime-encoding + :documentation + "It's supposed to be either: + :7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a + X-token or an ietf-token (whatever that means).") + (disposition + :type (or string null) + :initarg :disposition + :initform nil + :accessor mime-disposition) + (disposition-parameters + :type list + :initarg :disposition-parameters + :initform '() + :accessor mime-disposition-parameters)) + (:documentation + "Abstract base class for all types of MIME parts.")) + +(defclass mime-bodily-part (mime-part) + ((body + :initarg :body + :accessor mime-body)) + (:documentation + "Abstract base class for MIME parts with a body.")) + +(defclass mime-unknown-part (mime-bodily-part) + ((type + :initarg :type + :reader mime-type + :documentation + "The original type string from the MIME header.")) + (:documentation + "MIME part unknown to this library. Accepted but not handled.")) + +(defclass mime-text (mime-bodily-part) ()) + +;; This turns out to be handy when making methods specialised +;; non-textual attachments. +(defclass mime-binary (mime-bodily-part) ()) + +(defclass mime-image (mime-binary) ()) + +(defclass mime-audio (mime-binary) ()) + +(defclass mime-video (mime-binary) ()) + +(defclass mime-application (mime-binary) ()) + +(defclass mime-multipart (mime-part) + ((parts :initarg :parts + :accessor mime-parts))) + +(defclass mime-message (mime-part) + ((headers :initarg :headers + :initform '() + :type list + :accessor mime-message-headers) + (real-message :initarg :body + :accessor mime-body))) + +(defun mime-part-p (object) + (typep object 'mime-part)) + +(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys) + (call-next-method) + ;; The initialization argument of the PARTS slot of a mime-multipart + ;; is expected to be a list of mime-parts. Thus, we implicitly + ;; create the mime parts using the arguments found in this list. + (with-slots (parts) part + (when (slot-boundp part 'parts) + (setf parts + (mapcar #'(lambda (subpart) + (if (mime-part-p subpart) + subpart + (apply #'make-instance subpart))) + parts))))) + +(defmethod initialize-instance ((part mime-message) &key &allow-other-keys) + (call-next-method) + ;; Allow a list of mime parts to be specified as body of a + ;; mime-message. In that case we implicitly create a mime-multipart + ;; and assign to the body slot. + (with-slots (real-message) part + (when (and (slot-boundp part 'real-message) + (consp real-message)) + (setf real-message + (make-instance 'mime-multipart :parts real-message))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun alist= (alist1 alist2 &key (test #'eql)) + (null + (set-difference alist1 alist2 + :test #'(lambda (x y) + (and (funcall test (car x) (car y)) + (funcall test (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime= (mime1 mime2) + (:documentation + "Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ).")) + +(defmethod mime= ((part1 mime-part) (part2 mime-part)) + (macrolet ((null-or (compare x y) + `(or (and (not ,x) + (not ,y)) + (and ,x ,y + (,compare ,x ,y)))) + (cmp-slot (compare reader) + `(null-or ,compare (,reader part1) (,reader part2)))) + (and (eq (class-of part1) (class-of part2)) + (cmp-slot string-equal mime-subtype) + (alist= (mime-type-parameters part1) + (mime-type-parameters part2) + :test #'string-equal) + (cmp-slot string= mime-id) + (cmp-slot string= mime-description) + (cmp-slot eq mime-encoding) + (cmp-slot equal mime-disposition) + (alist= (mime-disposition-parameters part1) + (mime-disposition-parameters part2) + :test #'string-equal)))) + +(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart)) + (and (call-next-method) + (every #'mime= (mime-parts part1) (mime-parts part2)))) + +(defmethod mime= ((part1 mime-message) (part2 mime-message)) + (and (call-next-method) + (alist= (mime-message-headers part1) (mime-message-headers part2) + :test #'string=) + (mime= (mime-body part1) (mime-body part2)))) + +(defun mime-body-stream (mime-part &key (binary t)) + (make-instance (if binary + 'binary-input-adapter-stream + 'character-input-adapter-stream) + :source (mime-body mime-part))) + +(defun mime-body-length (mime-part) + (be body (mime-body mime-part) + ;; here the stream type is missing on purpose, because we may not + ;; be able to size the length of a stream + (etypecase body + (string + (length body)) + (vector + (length body)) + (pathname + (file-size body)) + (file-portion + (with-open-stream (in (open-decoded-file-portion body)) + (loop + for byte = (read-byte in nil) + while byte + count byte)))))) + +(defmacro with-input-from-mime-body-stream ((stream part &key (binary t)) &body forms) + `(with-open-stream (,stream (mime-body-stream ,part :binary ,binary)) + ,@forms)) + +(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part)) + (and (call-next-method) + (with-input-from-mime-body-stream (in1 part1) + (with-input-from-mime-body-stream (in2 part2) + (loop + for b1 = (read-byte in1 nil) + for b2 = (read-byte in2 nil) + always (eq b1 b2) + while (and b1 b2)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric get-mime-type-parameter (part name) + (:documentation + "Return the MIME type parameter associated to NAME of PART.")) + +(defgeneric (setf get-mime-type-parameter) (value part name) + (:documentation + "Set the MIME type parameter associated to NAME of PART.")) + +(defmethod get-mime-type-parameter ((part mime-part) name) + (cdr (assoc name (mime-type-parameters part) :test #'string-equal))) + +(defmethod (setf get-mime-type-parameter) (value part name) + (aif (assoc name (mime-type-parameters part) :test #'string-equal) + (setf (cdr it) value) + (push (cons name value) + (mime-type-parameters part))) + value) + +(defgeneric get-mime-disposition-parameter (part name) + (:documentation + "Return the MIME disposition parameter associated to NAME of PART.")) + +(defmethod get-mime-disposition-parameter ((part mime-part) name) + (cdr (assoc name (mime-disposition-parameters part) :test #'string-equal))) + +(defmethod (setf get-mime-disposition-parameter) (value part name) + (aif (assoc name (mime-disposition-parameters part) :test #'string-equal) + (setf (cdr it) value) + (push (cons name value) + (mime-disposition-parameters part)))) + +(defmethod mime-part-file-name ((part mime-part)) + "Return the filename associated to mime PART or NIL if the mime +part doesn't have a file name." + (or (get-mime-disposition-parameter part :filename) + (get-mime-type-parameter part :name))) + +(defmethod (setf mime-part-file-name) (value (part mime-part)) + "Set the filename associated to mime PART." + (setf (get-mime-disposition-parameter part :filename) value + (get-mime-type-parameter part :name) value)) + +(defun mime-text-charset (part) + (get-mime-type-parameter part :charset)) + +(defun split-header-parts (string) + "Split parts of a MIME headers. These are divided by +semi-colons not within strings or comments." + (labels ((skip-comment (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\( (setf pos (skip-comment (1+ pos)))) + (#\\ (incf pos 2)) + (#\) (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos))) + (skip-string (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\\ (incf pos 2)) + (#\" (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos)))) + (loop + with start = 0 and i = 0 and parts = '() + while (< i (length string)) + do (case (elt string i) + (#\; (push (subseq string start i) parts) + (setf start (incf i))) + (#\" (setf i (skip-string i))) + (#\( (setf i (skip-comment (1+ i)))) + (otherwise (incf i))) + finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts))))))) + +(defun parse-parameter (string) + "Given a string like \"foo=bar\" return a pair (\"foo\" . +\"bar\"). Return NIL if string is not parsable." + (be equal-position (position #\= string) + (when equal-position + (be key (subseq string 0 equal-position) + (if (= equal-position (1- (length string))) + (cons key "") + (be value (string-trim-whitespace (subseq string (1+ equal-position))) + (cons key + (if (and (> (length value) 1) + (char= #\" (elt value 0))) + ;; the syntax of a RFC822 string is more or + ;; less the same as the Lisp one: use the Lisp + ;; reader + (or (ignore-errors (read-from-string value)) + (subseq value 1)) + (be end (or (position-if #'whitespace-p value) + (length value)) + (subseq value 0 end)))))))))) + +(defun parse-content-type (string) + "Parse string as a Content-Type MIME header and return a list +of three elements. The first is the type, the second is the +subtype and the third is an alist of parameters and their values. +Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." + (let* ((parts (split-header-parts string)) + (content-type-string (car parts)) + (slash (position #\/ content-type-string))) + ;; You'd be amazed to know how many MUA can't produce an RFC + ;; compliant message. + (when slash + (let ((type (subseq content-type-string 0 slash)) + (subtype (subseq content-type-string (1+ slash)))) + (list type subtype (remove nil (mapcar #'parse-parameter (cdr parts)))))))) + +(defun parse-content-disposition (string) + "Parse string as a Content-Disposition MIME header and return a +list. The first element is the layout, the other elements are +the optional parameters alist. +Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." + (be parts (split-header-parts string) + (cons (car parts) (mapcan #'(lambda (parameter-string) + (awhen (parse-parameter parameter-string) + (list it))) + (cdr parts))))) + +(defun parse-RFC822-header (string) + "Parse STRING which should be a valid RFC822 message header and +return two values: a string of the header name and a string of +the header value." + (be colon (position #\: string) + (when colon + (values (string-trim-whitespace (subseq string 0 colon)) + (string-trim-whitespace (subseq string (1+ colon))))))) + + +(defvar *default-type* '("text" "plain" (("charset" . "us-ascii"))) + "Internal special variable that contains the default MIME type at +any given time of the parsing phase. There are MIME container parts +that may change this.") + +(defvar *mime-types* + '((:text mime-text) + (:image mime-image) + (:audio mime-audio) + (:video mime-video) + (:application mime-application) + (:multipart mime-multipart) + (:message mime-message))) + +(defgeneric mime-part-size (part) + (:documentation + "Return the size in bytes of the body of a MIME part.")) + +(defgeneric print-mime-part (part stream) + (:documentation + "Output to STREAM one of the possible human-readable representation +of mime PART. Binary parts are omitted. This function can be used to +quote messages, for instance.")) + +(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function) + "Read through BODY-STREAM. Call CONTENTS-FUNCTION at +each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." + (let* ((boundary (s+ "--" part-boundary)) + (boundary-length (length boundary))) + (labels ((output-line (line) + (funcall contents-function line)) + (end-part () + (funcall end-part-function)) + (last-part () + (end-part) + (return-from do-multipart-parts)) + (process-line (line) + (cond ((not (string-starts-with boundary line)) + ;; normal line + (output-line line)) + ((and (= (length (string-trim-whitespace line)) + (+ 2 boundary-length)) + (string= "--" line :start2 boundary-length)) + ;; end of the last part + (last-part)) + ;; according to RFC2046 "the boundary may be followed + ;; by zero or more characters of linear whitespace" + ((= (length (string-trim-whitespace line)) boundary-length) + ;; beginning of the next part + (end-part)) + (t + ;; the line boundary is followed by some + ;; garbage; we treat it as a normal line + (output-line line))))) + (loop + for line = (read-line body-stream nil) + ;; we should never reach the end of a proper multipart MIME + ;; stream, but we don't want to be fooled by corrupted ones, + ;; so we check for EOF + unless line + do (last-part) + do (process-line line))))) + +;; This awkward handling of newlines is due to RFC2046: "The CRLF +;; preceding the boundary delimiter line is conceptually attached to +;; the boundary so that it is possible to have a part that does not +;; end with a CRLF (line break). Body parts that must be considered +;; to end with line breaks, therefore, must have two CRLFs preceding +;; the boundary delimiter line, the first of which is part of the +;; preceding body part, and the second of which is part of the +;; encapsulation boundary". +(defun split-multipart-parts (body-stream part-boundary) + "Read from BODY-STREAM and split MIME parts separated by +PART-BOUNDARY. Return a list of strings." + (let ((part (make-string-output-stream)) + (parts '()) + (beginning-of-part-p t)) + (flet ((output-line (line) + (if beginning-of-part-p + (setf beginning-of-part-p nil) + (terpri part)) + (write-string line part)) + (end-part () + (setf beginning-of-part-p t) + (push (get-output-stream-string part) parts))) + (do-multipart-parts body-stream part-boundary #'output-line #'end-part) + (close part) + ;; the first part is empty or contains all the junk + ;; to the first boundary + (cdr (nreverse parts))))) + +(defun index-multipart-parts (body-stream part-boundary) + "Read from BODY-STREAM and return the file offset of the MIME parts +separated by PART-BOUNDARY." + (let ((parts '()) + (start 0) + (len 0) + (beginning-of-part-p t)) + (flet ((sum-chars (line) + (incf len (length line)) + ;; account for the #\newline + (if beginning-of-part-p + (setf beginning-of-part-p nil) + (incf len))) + (end-part () + (setf beginning-of-part-p t) + (push (cons start (+ start len)) parts) + (setf start (file-position body-stream) + len 0))) + (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part) + ;; the first part is all the stuff up to the first boundary; + ;; just junk + (cdr (nreverse parts))))) + +(defgeneric encode-mime-part (part stream)) +(defgeneric encode-mime-body (part stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun write-mime-header (part stream) + (when (mime-version part) + (format stream "~&MIME-Version: ~A~%" (mime-version part))) + (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-type-parameters part))) + (awhen (mime-encoding part) + (format stream "Content-Transfer-Encoding: ~A~%" it)) + (awhen (mime-description part) + (format stream "Content-Description: ~A~%" it)) + (when (mime-disposition part) + (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%" + (mime-disposition part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-disposition-parameters part)))) + (awhen (mime-id part) + (format stream "Content-ID: ~A~%" it)) + (terpri stream)) + +(defmethod encode-mime-part ((part mime-part) stream) + (write-mime-header part stream) + (encode-mime-body part stream)) + +(defmethod encode-mime-part ((part mime-message) stream) + ;; tricky: we have to mix the MIME headers with the message headers + (dolist (h (mime-message-headers part)) + (unless (stringp (car h)) + (setf (car h) + (string-capitalize (car h)))) + (unless (or (string-starts-with "content-" (car h) #'string-equal) + (string-equal "mime-version" (car h))) + (format stream "~A: ~A~%" + (car h) (cdr h)))) + (encode-mime-part (mime-body part) stream)) + +(defmethod encode-mime-part ((part mime-multipart) stream) + ;; choose a boundary if not already set + (let* ((original-boundary (get-mime-type-parameter part :boundary)) + (boundary (choose-boundary (mime-parts part) original-boundary))) + (unless (and original-boundary + (string= boundary original-boundary)) + (setf (get-mime-type-parameter part :boundary) boundary)) + (call-next-method))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod encode-mime-body ((part mime-part) stream) + (with-input-from-mime-body-stream (in part) + (encode-stream in stream (mime-encoding part)))) + +(defmethod encode-mime-body ((part mime-message) stream) + (encode-mime-body (mime-body part) stream)) + +(defmethod encode-mime-body ((part mime-multipart) stream) + (be boundary (or (get-mime-type-parameter part :boundary) + (setf (get-mime-type-parameter part :boundary) + (choose-boundary (mime-parts part)))) + (dolist (p (mime-parts part)) + (format stream "~%--~A~%" boundary) + (encode-mime-part p stream)) + (format stream "~%--~A--~%" boundary))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun time-RFC822-string (&optional (epoch (get-universal-time))) + "Return a string describing the current time according to +the RFC822." + (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch) + (declare (ignore dst)) + (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D" + (subseq (week-day->string week-day) 0 3) + day (subseq (month->string month) 0 3) (mod year 100) hh mm ss + (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60)))) + +(defun parse-RFC822-date (date-string) + "Parse a RFC822 compliant date string and return an universal +time." + ;; if we can't parse it, just return NIL + (ignore-errors + ;; skip the optional DoW + (awhen (position #\, date-string) + (setf date-string (subseq date-string (1+ it)))) + (destructuring-bind (day month year time &optional tz &rest rubbish) + (split-at '(#\space #\tab) date-string) + (declare (ignore rubbish)) + (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:) + (encode-universal-time + (if ss + (read-from-string ss) + 0) + (read-from-string mm) + (read-from-string hh) + (read-from-string day) + (1+ (position month + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :test #'string-equal)) + (read-from-string year) + (when (and tz (or (char= #\+ (elt tz 0)) + (char= #\- (elt tz 0)))) + (/ (read-from-string tz) 100))))))) + +(defun read-RFC822-headers (stream &optional required-headers) + "Read RFC822 compliant headers from STREAM and return them in a +alist of keyword and string pairs. REQUIRED-HEADERS is a list of +header names we are interested in; if NIL return all headers +found in STREAM." + ;; the skip-header variable is to avoid the mistake of appending a + ;; continuation line of a header we don't want to a header we want + (loop + with headers = '() and skip-header = nil + for line = (be line (read-line stream nil) + ;; skip the Unix "From " header if present + (if (string-starts-with "From " line) + (read-line stream nil) + line)) + then (read-line stream nil) + while (and line + (not (zerop (length line)))) + do (if (whitespace-p (elt line 0)) + (unless (or skip-header + (null headers)) + (setf (cdar headers) (s+ (cdar headers) '(#\newline) line))) + (multiple-value-bind (name value) (parse-RFC822-header line) + ;; the line contained rubbish instead of an header: we + ;; play nice and return as we were at the end of the + ;; headers + (unless name + (return (nreverse headers))) + (if (or (null required-headers) + (member name required-headers :test #'string-equal)) + (progn + (push (cons name value) headers) + (setf skip-header nil)) + (setf skip-header t)))) + finally (return (nreverse headers)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-message (thing) + (:documentation + "Convert THING to a MIME-MESSAGE object.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *lazy-mime-decode* t + "If true don't decode mime bodies in memory.") + +(defgeneric decode-mime-body (part input-stream)) + +(defmethod decode-mime-body ((part mime-part) (stream delimited-input-stream)) + (be base (base-stream stream) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (etypecase base + (my-string-input-stream + (stream-string base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (file-position stream) + :end (stream-end stream))) + (call-next-method)))) + +(defmethod decode-mime-body ((part mime-part) (stream file-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (pathname stream) + :encoding (mime-encoding part) + :start (file-position stream))) + (call-next-method))) + +(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (stream-string stream) + :encoding (mime-encoding part) + :start (file-position stream))) + (call-next-method))) + +(defmethod decode-mime-body ((part mime-part) stream) + (setf (mime-body part) + (decode-stream-to-sequence stream (mime-encoding part)))) + +(defmethod decode-mime-body ((part mime-multipart) stream) + "Decode STREAM according to PART characteristics and return a +list of MIME parts." + (save-file-excursion (stream) + (be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary)) + (setf (mime-parts part) + (mapcar #'(lambda (p) + (destructuring-bind (start . end) p + (be *default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii")))) + in (make-instance 'delimited-input-stream + :stream stream + :dont-close t + :start start + :end end) + (read-mime-part in)))) + offsets))))) + +(defmethod decode-mime-body ((part mime-message) stream) + "Read from STREAM the body of PART. Return the decoded MIME +body." + (setf (mime-body part) + (read-mime-message stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) + "List of known content encodings.") + +(defun keywordify-encoding (string) + "Return a keyword for a content transfer encoding string. +Return STRING itself if STRING is an unkown encoding." + (aif (member string +known-encodings+ :test #'string-equal) + (car it) + string)) + +(defun header (name headers) + (be elt (assoc name headers :test #'string-equal) + (values (cdr elt) (car elt)))) + +(defun (setf header) (value name headers) + (be entry (assoc name headers :test #'string-equal) + (unless entry + (error "missing header ~A can't be set" name)) + (setf (cdr entry) value))) + +(defun make-mime-part (headers stream) + "Create a MIME-PART object based on HEADERS and a body which +has to be read from STREAM. If the mime part type can't be +guessed from the headers, use the *DEFAULT-TYPE*." + (flet ((hdr (what) + (header what headers))) + (destructuring-bind (type subtype parms) + (or + (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal)) + 'mime-unknown-part)) + (disp (aif (hdr :content-disposition) + (parse-content-disposition it) + (values nil nil))) + (part (make-instance class + :type (hdr :content-type) + :subtype subtype + :type-parameters parms + :disposition (car disp) + :disposition-parameters (cdr disp) + :mime-version (hdr :mime-version) + :encoding (keywordify-encoding + (hdr :content-transfer-encoding)) + :description (hdr :content-description) + :id (hdr :content-id) + :allow-other-keys t))) + (decode-mime-body part stream) + part)))) + +(defun read-mime-part (stream) + "Read mime part from STREAM. Return a MIME-PART object." + (be headers (read-rfc822-headers stream + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)) + (make-mime-part headers stream))) + +(defun read-mime-message (stream) + "Main function to read a MIME message from a stream. It +returns a MIME-MESSAGE object." + (be headers (read-rfc822-headers stream) + *default-type* '("text" "plain" (("charset" . "us-ascii"))) + (flet ((hdr (what) + (header what headers))) + (destructuring-bind (type subtype parms) + (or (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (declare (ignore type subtype)) + (make-instance 'mime-message + :headers headers + ;; this is just for easy access + :type-parameters parms + :body (make-mime-part headers stream)))))) + +(defmethod mime-message ((msg mime-message)) + msg) + +(defmethod mime-message ((msg string)) + (with-open-stream (in (make-instance 'my-string-input-stream :string msg)) + (read-mime-message in))) + +(defmethod mime-message ((msg stream)) + (read-mime-message msg)) + +(defmethod mime-message ((msg pathname)) + (let (#+sbcl(sb-impl::*default-external-format* :latin-1) + #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) + (with-open-file (in msg) + (read-mime-message in)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-part (object) + (:documentation + "Promote object, if necessary, to MIME-PART.")) + +(defmethod mime-part ((object string)) + (make-instance 'mime-text :subtype "plain" :body object)) + +(defmethod mime-part ((object pathname)) + (make-instance 'mime-application + :subtype "octect-stream" + :content-transfer-encoding :base64 + :body (read-file object :element-type '(unsigned-byte 8)))) + +(defmethod mime-part ((object mime-part)) + object) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-encoded-body-stream ((part mime-bodily-part)) + (be body (mime-body part) + (make-instance (case (mime-encoding part) + (:base64 + 'base64-encoder-input-stream) + (:quoted-printable + 'quoted-printable-encoder-input-stream) + (t + '8bit-encoder-input-stream)) + :stream (make-instance 'binary-input-adapter-stream :source body)))) + +(defun choose-boundary (parts &optional default) + (labels ((match-in-parts (boundary parts) + (loop + for p in parts + thereis (typecase p + (mime-multipart + (match-in-parts boundary (mime-parts p))) + (mime-bodily-part + (match-in-body p boundary))))) + (match-in-body (part boundary) + (with-open-stream (in (make-encoded-body-stream part)) + (loop + for line = (read-line in nil) + while line + when (string= line boundary) + return t + finally (return nil))))) + (do ((boundary (if default + (format nil "--~A" default) + #1=(format nil "--~{~36R~}" + (loop + for i from 0 below 20 + collect (random 36)))) + #1#)) + ((not (match-in-parts boundary parts)) (subseq boundary 2))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; fall back method +(defmethod mime-part-size ((part mime-part)) + (be body (mime-body part) + (typecase body + (pathname + (file-size body)) + (string + (length body)) + (vector + (length body)) + (t nil)))) + +(defmethod mime-part-size ((part mime-multipart)) + (loop + for p in (mime-parts part) + for size = (mime-part-size p) + unless size + return nil + sum size)) + +(defmethod mime-part-size ((part mime-message)) + (mime-part-size (mime-body part))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod print-mime-part ((part mime-multipart) (out stream)) + (case (mime-subtype part) + (:alternative + ;; try to choose something simple to print or the first thing + (be parts (mime-parts part) + (print-mime-part (or (find-if #'(lambda (part) + (and (eq (class-of part) (find-class 'mime-text)) + (eq (mime-subtype part) :plain))) + parts) + (car parts)) out))) + (otherwise + (dolist (subpart (mime-parts part)) + (print-mime-part subpart out))))) + +;; This is WRONG. Here we don't use any special character encoding +;; because we don't know which one we should use. Messages written in +;; anything but ASCII will likely be unreadable -wcp11/10/07. +(defmethod print-mime-part ((part mime-text) (out stream)) + (be body (mime-body part) + (etypecase body + (string + (write-string body out)) + (vector + (loop + for byte across body + do (write-char (code-char byte) out))) + (pathname + (with-open-file (in body) + (loop + for c = (read-char in nil) + while c + do (write-char c out))))))) + +(defmethod print-mime-part ((part mime-message) (out stream)) + (flet ((hdr (name) + (multiple-value-bind (value tag) + (header name (mime-message-headers part)) + (cons tag value)))) + (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id"))) + (when h + (format out "~&~A: ~A" (car h) (cdr h)))) + (format out "~2%") + (print-mime-part (mime-body part) out))) + +(defmethod print-mime-part ((part mime-part) (out stream)) + (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%" + (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-part-by-path (mime path) + (:documentation + "Return a subpart of MIME identified by PATH, which is a list of +integers. For example '(2 3 1) is the first part of the third of the +second in MIME.")) + +(defmethod find-mime-part-by-path ((part mime-part) path) + (if (null path) + part + (error "~S doesn't have subparts" part))) + +(defmethod find-mime-part-by-path ((part mime-message) path) + (if (null path) + part + (if (= 1 (car path)) + (find-mime-part-by-path (mime-body part) (cdr path)) + (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)." + part (car path))))) + +(defmethod find-mime-part-by-path ((part mime-multipart) path) + (if (null path) + part + (be parts (mime-parts part) + part-number (car path) + (if (<= 1 part-number (length parts)) + (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path)) + (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)." + part (length parts) part-number))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-part-by-id (part id) + (:documentation + "Return a subpart of PAR, whose Content-ID is the same as ID, which +is a string.")) + +(defmethod find-mime-part-by-id ((part mime-part) id) + (when (string= id (mime-id part)) + part)) + +(defmethod find-mime-part-by-id ((part mime-message) id) + (find-mime-part-by-id (mime-body part) id)) + +(defmethod find-mime-part-by-id ((part mime-multipart) id) + (or (call-next-method) + (some #'(lambda (p) + (find-mime-part-by-id p id)) + (mime-parts part)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod find-mime-text-part (msg) + (:documentation + "Return message if it is a text message or first text part. + If no suitable text part is found, return NIL.")) + +(defmethod find-mime-text-part ((part mime-text)) + part) ; found our target + +(defmethod find-mime-text-part ((msg mime-message)) + ;; mime-body is either a mime-part or mime-multipart + (find-mime-text-part (mime-body msg))) + +(defmethod find-mime-text-part ((parts mime-multipart)) + ;; multipart messages may have a body, otherwise we + ;; search for the first text part + (or (call-next-method) + (find-if #'find-mime-text-part (mime-parts parts)))) + +(defmethod find-mime-text-part ((part mime-part)) + nil) ; default case + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-type-string (mime-part) + (:documentation + "Return the string describing the MIME part.")) + +(defmethod mime-type-string ((part mime-unknown-part)) + (mime-type part)) + +(defmethod mime-type-string ((part mime-text)) + (format nil "text/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-image)) + (format nil "image/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-audio)) + (format nil "audio/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-video)) + (format nil "video/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-application)) + (format nil "application/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-multipart)) + (format nil "multipart/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-message)) + (format nil "message/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-unknown-part)) + (mime-type part)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric map-parts (function mime-part) + (:documentation + "Recursively map FUNCTION to MIME-PART or its components.")) + +;; Here we wrongly assume that we'll never want to replace messages +;; and multiparts altogether. If you need to do so you have to write +;; your own mapping functions. + +(defmethod map-parts ((function function) (part mime-part)) + (funcall function part)) + +(defmethod map-parts ((function function) (part mime-message)) + (setf (mime-body part) (map-parts function (mime-body part))) + part) + +(defmethod map-parts ((function function) (part mime-multipart)) + (setf (mime-parts part) (mapcar #'(lambda (p) + (map-parts function p)) + (mime-parts part))) + part) + +;; apply-on-parts is like map-parts but doesn't modify the parts (at least +;; not implicitly) + +(defgeneric apply-on-parts (function part)) + +(defmethod apply-on-parts ((function function) (part mime-part)) + (funcall function part)) + +(defmethod apply-on-parts ((function function) (part mime-multipart)) + (dolist (p (mime-parts part)) + (apply-on-parts function p))) + +(defmethod apply-on-parts ((function function) (part mime-message)) + (apply-on-parts function (mime-body part))) + +(defmacro do-parts ((var mime-part) &body body) + `(apply-on-parts #'(lambda (,var) ,@body) ,mime-part)) diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd new file mode 100644 index 000000000000..e4d983c05760 --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl-tests.asd @@ -0,0 +1,54 @@ +;;; mime4cl-tests.asd --- system description for the regression tests + +;;; Copyright (C) 2006, 2007, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +#-(or sbcl cmu) +(warn "This code hasn't been tested on your Lisp system.") + +(defpackage :mime4cl-tests-system + (:use :common-lisp :asdf #+asdfa :asdfa) + (:export #:*base-directory* + #:*compilation-epoch*)) + +(in-package :mime4cl-tests-system) + +(defsystem mime4cl-tests + :name "MIME4CL-tests" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :description "Test suite for the MIME4CL library" + :long-description + "These regression tests require rt.lisp from MIT. It is included." + :licence "LGPL" + :depends-on (:mime4cl) + :components + ((:module test + :components + ((:file "rt") + (:file "package" :depends-on ("rt")) + (:file "endec" :depends-on ("rt" "package")) + (:file "address" :depends-on ("rt" "package")) + (:file "mime" :depends-on ("rt" "package")))))) + +;; when loading this form the regression-test, the package is yet to +;; be loaded so we cannot use rt:do-tests directly or we would get a +;; reader error (unknown package) +(defmethod perform ((o test-op) (c (eql (find-system :mime4cl-tests)))) + (or (funcall (intern "DO-TESTS" "REGRESSION-TEST")) + (error "test-op failed"))) diff --git a/third_party/lisp/mime4cl/mime4cl.asd b/third_party/lisp/mime4cl/mime4cl.asd new file mode 100644 index 000000000000..2761a00d5283 --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl.asd @@ -0,0 +1,53 @@ +;;; mime4cl.asd --- system definition + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or (at +;;; your option) any later version. +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; You should have received a copy of the GNU General Public License +;;; along with this program; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. + +(in-package :cl-user) + +#+(and cmu (not gray-streams)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (ext:without-package-locks + (load "library:subsystems/gray-streams-library"))) + +(defpackage :mime4cl-system + (:use :common-lisp :asdf)) + +(in-package :mime4cl-system) + +(defsystem mime4cl + :name "MIME4CL" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + ;; :version "0.0" + :description "MIME primitives for Common Lisp" + :long-description + "A collection of Common Lisp primitives to forge and handle +MIME mail contents." + :licence "LGPL" + :depends-on (:npg :sclf) + :components + ((:file "package") + (:file "mime" :depends-on ("package" "endec" "streams")) + (:file "endec" :depends-on ("package")) + (:file "streams" :depends-on ("package" "endec")) + (:file "address" :depends-on ("package")))) + +(defmethod perform ((o test-op) (c (eql (find-system 'mime4cl)))) + (oos 'load-op 'mime4cl-tests) + (oos 'test-op 'mime4cl-tests :force t)) diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp new file mode 100644 index 000000000000..a6e7e7d8ef10 --- /dev/null +++ b/third_party/lisp/mime4cl/package.lisp @@ -0,0 +1,108 @@ +;;; package.lisp --- package declaration + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :mime4cl + (:nicknames :mime) + (:use :common-lisp :npg :sclf + ;; for Gray streams + #+cmu :extensions #+sbcl :sb-gray) + ;; this is stuff that comes from SCLF and clashes with CMUCL's EXT + ;; package + (:shadowing-import-from :sclf + #:process-wait + #:process-alive-p + #:run-program) + (:export #:*lazy-mime-decode* + #:print-mime-part + #:read-mime-message + #:mime-part + #:mime-text + #:mime-binary + #:mime-id + #:mime-image + #:mime-message + #:mime-multipart + #:mime-audio + #:mime-unknown-part + #:get-mime-disposition-parameter + #:get-mime-type-parameter + #:mime-disposition + #:mime-disposition-parameters + #:mime-encoding + #:mime-application + #:mime-video + #:mime-description + #:mime-part-size + #:mime-subtype + #:mime-body + #:mime-body-stream + #:mime-body-length + #:mime-parts + #:mime-part-p + #:mime-type + #:mime-type-string + #:mime-type-parameters + #:mime-message-headers + #:mime= + #:find-mime-part-by-path + #:find-mime-part-by-id + #:find-mime-text-part + #:encode-mime-part + #:encode-mime-body + #:decode-quoted-printable-stream + #:decode-quoted-printable-string + #:encode-quoted-printable-stream + #:encode-quoted-printable-sequence + #:decode-base64-stream + #:decode-base64-string + #:encode-base64-stream + #:encode-base64-sequence + #:parse-RFC2047-text + #:parse-RFC822-header + #:read-RFC822-headers + #:time-RFC822-string + #:parse-RFC822-date + #:map-parts + #:do-parts + #:apply-on-parts + #:mime-part-file-name + #:mime-text-charset + #:with-input-from-mime-body-stream + ;; endec.lisp + #:base64-encoder + #:base64-decoder + #:null-encoder + #:null-decoder + #:byte-encoder + #:byte-decoder + #:quoted-printable-encoder + #:quoted-printable-decoder + #:encoder-write-byte + #:encoder-finish-output + #:decoder-read-byte + #:decoder-read-sequence + #:*base64-line-length* + #:*quoted-printable-line-length* + ;; address.lisp + #:parse-addresses #:mailboxes-only + #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address + #:mailbox-group #:mbxg-name #:mbxg-mailboxes)) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp new file mode 100644 index 000000000000..64c7adeec571 --- /dev/null +++ b/third_party/lisp/mime4cl/streams.lisp @@ -0,0 +1,368 @@ + ;;; eds.lisp --- En/De-coding Streams + + ;;; Copyright (C) 2012 by Walter C. Pelissero + ;;; Copyright (C) 2021 by the TVL Authors + + ;;; Author: Walter C. Pelissero <walter@pelissero.de> + ;;; Project: mime4cl + +#+cmu (ext:file-comment "$Module: eds.lisp") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl) + +#+cmu +(eval-when (:load-toplevel :compile-toplevel :execute) + ;; CMUCL doesn't provide the STREAM-FILE-POSITION method in its + ;; implementation of Gray streams. We patch it in ourselves. + (defgeneric stream-file-position (stream &optional position)) + (defun my-file-position (stream &optional position) + (stream-file-position stream position)) + (defvar *original-file-position-function* + (prog1 + (symbol-function 'file-position) + (setf (symbol-function 'file-position) (symbol-function 'my-file-position)))) + (defmethod stream-file-position (stream &optional position) + (if position + (funcall *original-file-position-function* stream position) + (funcall *original-file-position-function* stream))) + + ;; oddly CMUCL doesn't seem to provide a default for STREAM-READ-SEQUENCE + (defmacro make-read-sequence (stream-type element-reader) + `(defmethod stream-read-sequence ((stream ,stream-type) seq &optional start end) + (unless start + (setf start 0)) + (unless end + (setf end (length seq))) + (loop + for i from start below end + for b = (,element-reader stream) + until (eq b :eof) + do (setf (elt seq i) b) + finally (return i)))) + + (make-read-sequence fundamental-binary-input-stream stream-read-byte) + (make-read-sequence fundamental-character-input-stream stream-read-char)) + +(defclass coder-stream-mixin () + ((real-stream :type stream + :initarg :stream + :reader real-stream) + (dont-close :initform nil + :initarg :dont-close))) + +(defmethod stream-file-position ((stream coder-stream-mixin) &optional position) + (apply #'file-position (remove nil (list (slot-value stream 'real-stream) + position)))) + +(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin) + ()) +(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin) + ()) + + +(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ()) +(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ()) +(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ()) + +(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ()) +(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ()) +(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys) + (unless (slot-boundp stream 'real-stream) + (error "REAL-STREAM is unbound. Must provide a :STREAM argument."))) + +(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'output-function) + (setf (slot-value stream 'output-function) + #'(lambda (char) + (write-char char (slot-value stream 'real-stream)))))) + +(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'input-function) + (setf (slot-value stream 'input-function) + #'(lambda () + (read-char (slot-value stream 'real-stream) nil))))) + +(defmethod stream-read-byte ((stream coder-input-stream-mixin)) + (or (decoder-read-byte stream) + :eof)) + +(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte) + (encoder-write-byte stream byte)) + +(defmethod close ((stream coder-stream-mixin) &key abort) + (with-slots (real-stream dont-close) stream + (unless dont-close + (close real-stream :abort abort)))) + +(defmethod close ((stream coder-output-stream-mixin) &key abort) + (unless abort + (encoder-finish-output stream)) + (call-next-method)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((encoder) + (buffer-queue :initform (make-queue))) + (:documentation + "This is the base class for encoders with the direction swapped. It +reads from REAL-STREAM a stream of bytes, encodes it and returnes it +in a stream of character.")) + +(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ()) +(defclass base64-encoder-input-stream (encoder-input-stream) ()) +(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ()) + +(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys) + (call-next-method) + (with-slots (encoder buffer-queue) stream + (setf encoder + (make-instance 'quoted-printable-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) + +(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys) + (call-next-method) + (with-slots (encoder buffer-queue) stream + (setf encoder + (make-instance 'base64-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) + +(defmethod stream-read-char ((stream encoder-input-stream)) + (with-slots (encoder buffer-queue real-stream) stream + (loop + while (queue-empty-p buffer-queue) + do (be byte (read-byte real-stream nil) + (if byte + (encoder-write-byte encoder byte) + (progn + (encoder-finish-output encoder) + (queue-append buffer-queue :eof))))) + (queue-pop buffer-queue))) + + +(defmethod stream-read-char ((stream 8bit-encoder-input-stream)) + (with-slots (real-stream) stream + (aif (read-byte real-stream nil) + (code-char it) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass input-adapter-stream () + ((source :initarg :source) + (real-stream) + (input-function))) + +(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ()) + +(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ()) + +(defmethod stream-element-type ((stream binary-input-adapter-stream)) + '(unsigned-byte 8)) + +(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys) + (call-next-method) + (assert (slot-boundp stream 'source))) + +(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys) + (call-next-method) + ;; REAL-STREAM slot is set only if we are going to close it later on + (with-slots (source real-stream input-function) stream + (etypecase source + (string + (setf real-stream (make-string-input-stream source) + input-function #'(lambda () + (awhen (read-char real-stream nil) + (char-code it))))) + ((vector (unsigned-byte 8)) + (be i 0 + (setf input-function #'(lambda () + (when (< i (length source)) + (prog1 (aref source i) + (incf i))))))) + (stream + (assert (input-stream-p source)) + (setf input-function (if (subtypep (stream-element-type source) 'character) + #'(lambda () + (awhen (read-char source nil) + (char-code it))) + #'(lambda () + (read-byte source nil))))) + (pathname + (setf real-stream (open source :element-type '(unsigned-byte 8)) + input-function #'(lambda () + (read-byte real-stream nil)))) + (file-portion + (setf real-stream (open-decoded-file-portion source) + input-function #'(lambda () + (read-byte real-stream nil))))))) + +(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys) + (call-next-method) + ;; REAL-STREAM slot is set only if we are going to close later on + (with-slots (source real-stream input-function) stream + (etypecase source + (string + (setf real-stream (make-string-input-stream source) + input-function #'(lambda () + (read-char real-stream nil)))) + ((vector (unsigned-byte 8)) + (be i 0 + (setf input-function #'(lambda () + (when (< i (length source)) + (prog1 (code-char (aref source i)) + (incf i))))))) + (stream + (assert (input-stream-p source)) + (setf input-function (if (subtypep (stream-element-type source) 'character) + #'(lambda () + (read-char source nil)) + #'(lambda () + (awhen (read-byte source nil) + (code-char it)))))) + (pathname + (setf real-stream (open source :element-type 'character) + input-function #'(lambda () + (read-char real-stream nil)))) + (file-portion + (setf real-stream (open-decoded-file-portion source) + input-function #'(lambda () + (awhen (read-byte real-stream nil) + (code-char it)))))))) + +(defmethod close ((stream input-adapter-stream) &key abort) + (when (slot-boundp stream 'real-stream) + (with-slots (real-stream) stream + (close real-stream :abort abort)))) + +(defmethod stream-read-byte ((stream binary-input-adapter-stream)) + (with-slots (input-function) stream + (or (funcall input-function) + :eof))) + +(defmethod stream-read-char ((stream character-input-adapter-stream)) + (with-slots (input-function) stream + (or (funcall input-function) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((start-offset :initarg :start + :initform 0 + :reader stream-start + :type integer) + (end-offset :initarg :end + :initform nil + :reader stream-end + :type (or null integer)))) + +(defmethod print-object ((object delimited-input-stream) stream) + (if *print-readably* + (call-next-method) + (with-slots (start-offset end-offset) object + (print-unreadable-object (object stream :type t :identity t) + (format stream "start=~A end=~A" start-offset end-offset))))) + +(defun base-stream (stream) + (if (typep stream 'delimited-input-stream) + (base-stream (real-stream stream)) + stream)) + +(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'real-stream) + (error "REAL-STREAM is unbound. Must provide a :STREAM argument.")) + (with-slots (start-offset) stream + (when start-offset + (file-position stream start-offset)))) + +(defmethod stream-read-char ((stream delimited-input-stream)) + (with-slots (real-stream end-offset) stream + (if (or (not end-offset) + (< (file-position real-stream) end-offset)) + (or (read-char real-stream nil) + :eof) + :eof))) + +#+(OR)(defmethod stream-read-byte ((stream delimited-input-stream)) + (with-slots (real-stream end-offset) stream + (if (or (not end-offset) + (< (file-position real-stream) end-offset)) + (or (read-byte real-stream nil) + :eof) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((string :initarg :string + :reader stream-string))) + +(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys) + (call-next-method) + (assert (slot-boundp stream 'string)) + (with-slots (string real-stream) stream + (setf real-stream (make-string-input-stream string)))) + +(defmethod stream-read-char ((stream my-string-input-stream)) + (with-slots (real-stream) stream + (or (read-char real-stream nil) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct file-portion + data ; string or a pathname + encoding + start + end) + +(defun open-file-portion (file-portion) + (be data (file-portion-data file-portion) + (etypecase data + (pathname + (be stream (open data) + (make-instance 'delimited-input-stream + :stream stream + :start (file-portion-start file-portion) + :end (file-portion-end file-portion)))) + (string + (make-instance 'delimited-input-stream + :stream (make-string-input-stream data) + :start (file-portion-start file-portion) + :end (file-portion-end file-portion))) + (stream + (make-instance 'delimited-input-stream + :stream data + :dont-close t + :start (file-portion-start file-portion) + :end (file-portion-end file-portion)))))) + +(defun open-decoded-file-portion (file-portion) + (make-instance (case (file-portion-encoding file-portion) + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'base64-decoder-stream) + (t '8bit-decoder-stream)) + :stream (open-file-portion file-portion))) diff --git a/third_party/lisp/mime4cl/test/address.lisp b/third_party/lisp/mime4cl/test/address.lisp new file mode 100644 index 000000000000..aaa2d231f11c --- /dev/null +++ b/third_party/lisp/mime4cl/test/address.lisp @@ -0,0 +1,124 @@ +;;; address.lisp --- tests for the e-mail address parser + +;;; Copyright (C) 2007, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +#+cmu (ext:file-comment "$Module: address.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defun test-parsing (string) + (format nil "~{~A~^, ~}" (parse-addresses string))) + +(deftest address-parse-simple.1 + (test-parsing "foo@bar") + "foo@bar") + +(deftest address-parse-simple.2 + (test-parsing "foo@bar.com") + "foo@bar.com") + +(deftest address-parse-simple.3 + (test-parsing "foo@bar.baz.com") + "foo@bar.baz.com") + +(deftest address-parse-simple.4 + (test-parsing "foo.ooo@bar.baz.com") + "foo.ooo@bar.baz.com") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-simple-commented.1 + (test-parsing "foo@bar (Some Comment)") + "\"Some Comment\" <foo@bar>") + +(deftest address-parse-simple-commented.2 + (test-parsing "foo@bar (Some, Comment)") + "\"Some, Comment\" <foo@bar>") + +(deftest address-parse-simple-commented.3 + (test-parsing "foo@bar (Some Comment (yes, indeed))") + "\"Some Comment (yes, indeed)\" <foo@bar>") + +(deftest address-parse-simple-commented.4 + (test-parsing "foo.bar@host.complicated.domain.net (Some Comment (yes, indeed))") + "\"Some Comment (yes, indeed)\" <foo.bar@host.complicated.domain.net>") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-angle.1 + (test-parsing "<foo@bar.baz.net>") + "foo@bar.baz.net") + +(deftest address-parse-angle.2 + (test-parsing "My far far friend <foo@bar.baz.net>") + "\"My far far friend\" <foo@bar.baz.net>") + +(deftest address-parse-angle.3 + (test-parsing "\"someone, I don't like\" <foo@bar.baz.net>") + "\"someone, I don't like\" <foo@bar.baz.net>") + +(deftest address-parse-angle.4 + (test-parsing "\"this could (be a comment)\" <foo@bar.net>") + "\"this could (be a comment)\" <foo@bar.net>") + +(deftest address-parse-angle.5 + (test-parsing "don't be fooled <foo@bar.net>") + "\"don't be fooled\" <foo@bar.net>") + +(deftest address-parse-angle.6 + (test-parsing "<foo@bar>") + "foo@bar") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-domain-literal.1 + (test-parsing "<foo@[bar]>") + "foo@[bar]") + +(deftest address-parse-domain-literal.2 + (test-parsing "<foo@[bar.net]>") + "foo@[bar.net]") + +(deftest address-parse-domain-literal.3 + (test-parsing "<foo@[10.0.0.2]>") + "foo@[10.0.0.2]") + +(deftest address-parse-domain-literal.4 + (test-parsing "<foo.bar@[10.0.0.2]>") + "foo.bar@[10.0.0.2]") + +(deftest address-parse-domain-literal.5 + (test-parsing "somewhere unkown <foo.bar@[10.0.0.2]>") + "\"somewhere unkown\" <foo.bar@[10.0.0.2]>") + +(deftest address-parse-domain-literal.6 + (test-parsing "\"Some--One\" <foo.bar@[10.0.0.23]>") + "\"Some--One\" <foo.bar@[10.0.0.23]>") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-group.1 + (test-parsing "friends:john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];") + "friends: john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-mixed.1 + (test-parsing "Foo BAR <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends:john@bar,jack@pub;, foo.bar.baz@wow.mail.mine, dont.bark@me (Fierce Dog)") + "\"Foo BAR\" <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends: john@bar, jack@pub;, foo.bar.baz@wow.mail.mine, \"Fierce Dog\" <dont.bark@me>") diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp new file mode 100644 index 000000000000..7b6763c99035 --- /dev/null +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -0,0 +1,167 @@ +;;; endec.lisp --- test suite for the MIME encoder/decoder functions + +;;; Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +#+cmu (ext:file-comment "$Module: endec.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(deftest quoted-printable.1 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Français, Español, böse, skøl")) + "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l") + +(deftest quoted-printable.2 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Français, Español, böse, skøl") + :start 10 :end 17) + "Espa=F1ol") + +(deftest quoted-printable.3 + (map 'string #'code-char + (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")) + "Français, Español, böse, skøl") + +(deftest quoted-printable.4 + (map 'string #'code-char + (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l" + :start 12 :end 21)) + "Español") + +(deftest quoted-printable.5 + (map 'string #'code-char + (decode-quoted-printable-string "this = wrong")) + "this = wrong") + +(deftest quoted-printable.6 + (map 'string #'code-char + (decode-quoted-printable-string "this is wrong=")) + "this is wrong=") + +(deftest quoted-printable.7 + (map 'string #'code-char + (decode-quoted-printable-string "this is wrong=1")) + "this is wrong=1") + +(deftest quoted-printable.8 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "x = x + 1")) + "x =3D x + 1") + +(deftest quoted-printable.9 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "x = x + 1 ")) + "x =3D x + 1 =20") + +(deftest quoted-printable.10 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "this string is very very very very very very very very very very very very very very very very very very very very long")) + "this string is very very very very very very very very very very very ve= +ry very very very very very very very very long") + +(deftest quoted-printable.11 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "this string is very very very very long")) + "this string is very very = + very very long") + +(deftest quoted-printable.12 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "please read the next +line")) + "please read the next =20 +line") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest base64.1 + (let ((*base64-line-length* nil)) + (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Some random string."))) + "U29tZSByYW5kb20gc3RyaW5nLg==") + +(deftest base64.2 + (let ((*base64-line-length* nil)) + (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Some random string.") :start 5 :end 11)) + "cmFuZG9t") + +(deftest base64.3 + (map 'string #'code-char + (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + "Some random string.") + +(deftest base64.4 + (map 'string #'code-char + (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" + :start 13 :end 41)) + "Some random string.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest RFC2047.1 + (parse-RFC2047-text "foo bar") + ("foo bar")) + +(defun perftest-encoder (encoder-class &optional (megs 100)) + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type fixnum megs)) + (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) (declare (ignore c)))))) + (declare (type fixnum meg)) + (time + (progn + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder)))))) + +(defun perftest-decoder (decoder-class &optional (megs 100)) + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type fixnum megs)) + (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) + (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) + :type "encoded-data"))) + (sclf:with-temp-file (tmp nil :direction :io) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder-class (ecase decoder-class + (mime4cl:base64-decoder 'mime4cl:base64-encoder) + (mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder))) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) + (write-char c tmp)))) + (decoder (make-instance decoder-class + :input-function #'(lambda () + (read-char tmp nil))))) + (declare (type fixnum meg)) + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder) + (file-position tmp 0) + (time + (loop + for b = (mime4cl:decoder-read-byte decoder) + while b))))))) diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp new file mode 100644 index 000000000000..1488f927fcd3 --- /dev/null +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -0,0 +1,56 @@ + ;;; mime.lisp --- MIME regression tests + + ;;; Copyright (C) 2012 by Walter C. Pelissero + ;;; Copyright (C) 2021 by the TVL Authors + + ;;; Author: Walter C. Pelissero <walter@pelissero.de> + ;;; Project: mime4cl + +#+cmu (ext:file-comment "$Module: mime.lisp") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defvar *samples-directory* + (merge-pathnames (make-pathname :directory '(:relative "samples")) + #.(or *compile-file-pathname* + *load-pathname* + #P""))) + +(defvar *sample1-file* (make-pathname :defaults #.(or *compile-file-pathname* + *load-pathname*) + :name "sample1" + :type "msg")) + +(deftest mime.1 + (let* ((orig (mime-message *sample1-file*)) + (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (mime= orig dup)) + t) + +(deftest mime.2 + (loop + for f in (directory (make-pathname :defaults *samples-directory* + :name :wild + :type "txt")) + do + (format t "~A:~%" f) + (finish-output) + (let* ((orig (mime-message f)) + (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (unless (mime= orig dup) + (return nil))) + finally (return t)) + t) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp new file mode 100644 index 000000000000..bde0bf25d5b1 --- /dev/null +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -0,0 +1,28 @@ +;;; package.lisp --- package description for the regression tests + +;;; Copyright (C) 2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(cl:in-package :common-lisp) + +(defpackage :mime4cl-tests + (:use :common-lisp + :rtest :mime4cl) + (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp new file mode 100644 index 000000000000..d4dd2aedb677 --- /dev/null +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -0,0 +1,254 @@ +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +(defpackage #:regression-test + (:nicknames #:rtest #-lispworks #:rt) + (:use #:cl) + (:export #:*do-tests-when-defined* #:*test* #:continue-testing + #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) + (:documentation "The MIT regression tester with pfdietz's modifications")) + +(in-package :regression-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t + "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") +(defvar *compile-tests* nil + "When true, compile the tests before running them.") +(defvar *optimization-settings* '((safety 3))) +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters." + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (null pending)))) diff --git a/third_party/lisp/mime4cl/test/sample1.msg b/third_party/lisp/mime4cl/test/sample1.msg new file mode 100644 index 000000000000..662a9fab341e --- /dev/null +++ b/third_party/lisp/mime4cl/test/sample1.msg @@ -0,0 +1,86 @@ +From wcp@scylla.home.lan Fri Feb 17 11:02:28 2012 +Status: RO +X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil] + ["1133" "Friday" "17" "February" "2012" "11:02:27" "+0100" "Walter C. Pelissero" "walter@pelissero.de" nil "56" "test" "^From:" nil nil "2" nil nil nil nil nil nil nil nil nil nil] + nil) +X-Clpmr-Processed: 2012-02-17T11:02:31 +X-Clpmr-Version: 2011-10-23T12:55:20, SBCL 1.0.49 +Received: from scylla.home.lan (localhost [127.0.0.1]) + by scylla.home.lan (8.14.5/8.14.5) with ESMTP id q1HA2Sik004513 + for <wcp@scylla.home.lan>; Fri, 17 Feb 2012 11:02:28 +0100 (CET) + (envelope-from wcp@scylla.home.lan) +Received: (from wcp@localhost) + by scylla.home.lan (8.14.5/8.14.5/Submit) id q1HA2SqU004512; + Fri, 17 Feb 2012 11:02:28 +0100 (CET) + (envelope-from wcp) +Message-ID: <20286.9651.890757.323027@scylla.home.lan> +X-Mailer: VM 8.1.1 under 23.3.1 (amd64-portbld-freebsd8.2) +Reply-To: walter@pelissero.de +X-Attribution: WP +X-For-Spammers: blacklistme@pelissero.de +X-MArch-Processing-Time: 0.552s +MIME-Version: 1.0 +Content-Type: multipart/mixed; boundary="615CiWUaGO" +Content-Transfer-Encoding: 7BIT +From: walter@pelissero.de (Walter C. Pelissero) +To: wcp@scylla.home.lan +Subject: test +Date: Fri, 17 Feb 2012 11:02:27 +0100 + + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + +Hereafter three attachments. + +The first: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach1" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach1" + +YXR0YWNoMQo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + + +The second: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach2" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach2" + +YXR0YWNoMgo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + + +The third: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach3" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach3" + +YXR0YWNoMwo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: .signature + + +-- +http://pelissero.de +--615CiWUaGO-- + diff --git a/third_party/lisp/moptilities.nix b/third_party/lisp/moptilities.nix new file mode 100644 index 000000000000..a8a387ab914f --- /dev/null +++ b/third_party/lisp/moptilities.nix @@ -0,0 +1,18 @@ +# Compatibility layer for minor MOP implementation differences +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "gwkkwg"; + repo = "moptilities"; + rev = "a436f16b357c96b82397ec018ea469574c10dd41"; + sha256 = "1q12bqjbj47lx98yim1kfnnhgfhkl80102fkgp9pdqxg0fp6g5fc"; +}; +in depot.nix.buildLisp.library { + name = "moptilities"; + deps = [ depot.third_party.lisp.closer-mop ]; + srcs = [ "${src}/dev/moptilities.lisp" ]; + + brokenOn = [ + "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651 + ]; +} diff --git a/third_party/lisp/nibbles.nix b/third_party/lisp/nibbles.nix new file mode 100644 index 000000000000..da542fe91130 --- /dev/null +++ b/third_party/lisp/nibbles.nix @@ -0,0 +1,32 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + src = pkgs.fetchFromGitHub { + owner = "sharplispers"; + repo = "nibbles"; + rev = "dad25240928d5cf8f7df69c4398244e03570bb35"; + sha256 = "0r6ljlpgjmkf87pmvdwzva8qj15bhznc3ylgcjjqyy4frbx9lygz"; + name = "nibbles-source"; + }; + +in depot.nix.buildLisp.library { + name = "nibbles"; + + deps = with depot.third_party.lisp; [ + (bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "types.lisp" + "macro-utils.lisp" + "vectors.lisp" + "streams.lisp" + ] ++ [ + { sbcl = "${src}/sbcl-opt/fndb.lisp"; } + { sbcl = "${src}/sbcl-opt/nib-tran.lisp"; } + { sbcl = "${src}/sbcl-opt/x86-vm.lisp"; } + { sbcl = "${src}/sbcl-opt/x86-64-vm.lisp"; } + ]; +} diff --git a/third_party/lisp/npg/.project b/third_party/lisp/npg/.project new file mode 100644 index 000000000000..82a8fe48bbfb --- /dev/null +++ b/third_party/lisp/npg/.project @@ -0,0 +1 @@ +NPG a Naive Parser Generator diff --git a/third_party/lisp/npg/.skip-subtree b/third_party/lisp/npg/.skip-subtree new file mode 100644 index 000000000000..5051f60d6b86 --- /dev/null +++ b/third_party/lisp/npg/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING new file mode 100644 index 000000000000..223ede7de3ec --- /dev/null +++ b/third_party/lisp/npg/COPYING @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/third_party/lisp/npg/OWNERS b/third_party/lisp/npg/OWNERS new file mode 100644 index 000000000000..f16dd105d761 --- /dev/null +++ b/third_party/lisp/npg/OWNERS @@ -0,0 +1,3 @@ +inherited: true +owners: + - sterni diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README new file mode 100644 index 000000000000..a1661e744a37 --- /dev/null +++ b/third_party/lisp/npg/README @@ -0,0 +1,48 @@ + + NPG a Naive Parser Generator + for Common Lisp + + Copyright (C) 2003-2006, 2010 by Walter C. Pelissero + Copyright (C) 2021 by the TVL Authors + +Vendored into depot as it is a dependency of mime4cl and upstream has +become inactive. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#npg +Vendored Tarball: http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz + +This library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation; either version 2.1 of the +License, or (at your option) any later version. This library is +distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. You should have received a copy of the GNU +Lesser General Public License along with this library; if not, write +to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +Boston, MA 02111-1307 USA + + +This library generates on the fly (no external representation of the +parser is produced) a recursive descent parser based on the grammar +rules you have fed it with. The parser object can then be used to +scan tokenised input. Although a facility to produce a lexical +analiser is not provided, to write such a library is fairly easy for +most languages. NPG parsers require your lexer to adhere to a certain +protocol to be able to communicate with them. Examples are provided +that explain these requirements. + +While quite possibly not producing the fastest parsers in town, it's +fairly simple and hopefully easy to debug. It accepts a lispy EBNF +grammar description of arbitrary complexity with the exception of +mutually left recursive rules (watch out, they produce undetected +infinite recursion) and produces a backtracking recursive descent +parser. Immediate left recursive rules are properly simplified, +though. + +Multiple concurrent parsers are supported. + +To compile, an ASDF and nix file are provided. + +See the examples directory for clues on how to use it. diff --git a/third_party/lisp/npg/default.nix b/third_party/lisp/npg/default.nix new file mode 100644 index 000000000000..af7ec53eaf93 --- /dev/null +++ b/third_party/lisp/npg/default.nix @@ -0,0 +1,14 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "npg"; + + srcs = [ + ./src/package.lisp + ./src/common.lisp + ./src/define.lisp + ./src/parser.lisp + ]; +} diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp new file mode 100644 index 000000000000..68d794ddec03 --- /dev/null +++ b/third_party/lisp/npg/examples/python.lisp @@ -0,0 +1,336 @@ +;;; python.lisp --- sample grammar definition for the Python language + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is far from being a complete Python grammar. Actually I +;;; haven't even read a Python book before starting to write this +;;; stuff, so the code below comes mostly from wild guessing while +;;; reading a Python source file. +;;; +;;; It's a design decision to avoid writing any transformation in this +;;; module; only tagging is done at this level. This improves the +;;; separation between parsing and transformation, making the grammar +;;; reusable for other purposes. + + +#+cmu (ext:file-comment "$Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $") + +(in-package :grammar) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "~&creating Python grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () + +(defrule program + := comment-string? statement+) + +(defrule comment-string + := string eol + :reduce string) + +;;; BOB = Beginning Of Block, EOB = End Of Block. It's lexical +;;; analyzer's task to find out where a statement or block starts/ends. + +(defrule suite + := statement-list eol + :reduce statement-list + := statement-block) + +(defrule commentable-suite + := statement-list eol + :reduce statement-list + := commented-statement-block) + +(defrule statement-block + := bob statement+ eob + :reduce $2) + +(defrule commented-statement-block + := bob comment-string? statement* eob + :reduce (cons comment-string statement)) + +(defrule statement-list + := (+ simple-statement ";") + :reduce (if (cdr $1) + (cons :statement-list $1) + (car $1))) + +(defrule statement + := statement-list eol + :reduce statement-list + := compound-statement) + +(defrule simple-statement + := import-statement + := raise-statement + := assignment + := function-call + := return-statement + := assert-statement + := pass-statement + := break-statement + := continue-statement) + +(defrule compound-statement + := class-definition + := method-definition + := try-statement + := if-statement + := while-statement + := for-statement) + +(defrule import-statement + := "import" (+ package-name ",") + :tag :import + := "from" package-name "import" (+ symbol-name ",") + :tag :import-from) + +(defrule package-name := identifier) + +(defrule symbol-name + := identifier + := "*") + +(defrule try-statement + := "try" ":" suite try-except-part* try-finally-part? + :tag :try) + +(defrule try-except-part + := "except" exception-subject? ":" suite) + +(defrule try-finally-part + := "finally" ":" suite) + +(defrule exception-subject + := exception-name exception-variable?) + +(defrule exception-variable + := "," identifier) + +(defrule exception-name := class-name) + +(defrule class-name := identifier) + +(defrule raise-statement + := "raise" + :tag :raise-same + := "raise" exception-name + :tag :raise + := "raise" exception-name "," expression + :tag :raise + := "raise" exception-name "(" expression ")" + :tag :raise) + +(defrule assignment + := (+ variable-with-optional-subscript ",") "=" more-assignment + :tag :set) + +(defrule more-assignment + := expression + := assignment) + +(defrule variable-with-optional-subscript + := variable-name subscript + :tag :subscript + := variable-name) + +(defrule variable-name + := (+ identifier ".") + :tag :varef) + +(defrule expression + := expression "or" expression1 + :tag :or + := expression1) + +(defrule expression1 + := expression1 "and" expression2 + :tag :and + := expression2) + +(defrule expression2 + := expression2 "==" expression3 + :tag :equal + := expression2 ">=" expression3 + :tag :more-equal + := expression2 "<=" expression3 + :tag :less-equal + := expression2 "!=" expression3 + :tag :not-equal + := expression2 ">" expression3 + :tag :more + := expression2 "<" expression3 + :tag :less + := expression2 "is" expression3 + :tag :equal + := expression2 "is" "not" expression3 + :tag :not-equal + := expression3) + +(defrule expression3 + := expression3 "+" expression4 + :tag :plus + := expression3 "-" expression4 + :tag :minus + := expression3 "|" expression4 + :tag :bit-or + := expression4) + +;; high priority expression +(defrule expression4 + := expression4 "*" expression5 + :tag :mult + := expression4 "/" expression5 + :tag :div + := expression4 "%" expression5 + :tag :modulo + := expression4 "&" expression5 + :tag :bit-and + := expression4 "in" expression5 + :tag :in + := expression5) + +(defrule expression5 + := "~" expression5 + :tag :bit-not + := "not" expression5 + :tag :not + := "(" expression ")" + := expression6) + +(defrule expression6 + := simple-expression subscript + :tag :subscript + := simple-expression) + +(defrule simple-expression + := function-call + := variable-name + := constant + := string-conversion + := list-constructor) + +(defrule subscript + := "[" expression "]" + := "[" expression ":" expression "]" + := "[" expression ":" "]" + :reduce (list expression nil) + := "[" ":" expression "]" + :reduce (list nil expression)) + +(defrule string-conversion + := "`" expression "`" + :tag :to-string) + +(defrule constant + := number + := string + := lambda-expression) + +(defrule number + := float + := integer) + +(defrule list-constructor + := "[" (* expression ",") "]" + :tag :make-list) + +(defrule class-definition + := "class" class-name superclasses? ":" commentable-suite + :tag :defclass) + +(defrule superclasses + := "(" class-name+ ")") + +(defrule method-definition + := "def" method-name "(" method-arguments ")" ":" commentable-suite + :tag :defmethod) + +(defrule method-arguments + := (* method-argument ",")) + +(defrule method-argument + := identifier argument-default?) + +(defrule argument-default + := "=" expression) + +(defrule method-name := identifier) + +(defrule if-statement + := "if" expression ":" suite elif-part* else-part? + :tag :if) + +(defrule else-part + := "else" ":" suite) + +(defrule elif-part + := "elif" expression ":" suite) + +(defrule lambda-expression + := "lambda" method-arguments ":" expression + :tag :lambda) + +(defrule function-call + := (+ identifier ".") "(" (* expression ",") ")" + :tag :funcall) + +(defrule for-statement + := "for" identifier "in" expression ":" suite + :tag :do-list + := "for" identifier "in" "range" "(" expression "," expression ")" ":" suite + :tag :do-range) + +(defrule while-statement + := "while" expression ":" suite + :tag :while) + +(defrule return-statement + := "return" expression? + :tag :return) + +(defrule assert-statement + := "assert" expression "," string + :tag :assert) + +(defrule pass-statement + := "pass" + :tag :pass) + +(defrule break-statement + := "break" + :tag :break) + +(defrule continue-statement + := "continue" + :tag :continue) + +) ; end of POPULATE-GRAMMAR diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp new file mode 100644 index 000000000000..2edf1292da53 --- /dev/null +++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp @@ -0,0 +1,1901 @@ +;;; vs-cobol-ii.lisp --- sample grammar for VS-Cobol II + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; A fairly incomplete VS-Cobol II grammar fro NPG. It's probably +;;; not very accurate either. + +#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $") + +(in-package :grammar) + +(defun make-keyword (string) + "Create a keyword from STRING." + (intern (string-upcase string) :keyword)) + +(defun flatten-list (list) + "Remove one depth level in LIST." + (mapcan #'identity list)) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "creating Cobol grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () +;;; +;;; Hereafter PP means Partial Program +;;; + +#+nil +(defrule pp--declarations + := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest) + +;;; We need to split the parsing of the declarations from the rest +;;; because the declarations may change the lexical rules (ie decimal +;;; point) + +(defrule pp--declarations + := identification-division environment-division? data-division-head-or-procedure-division-head :rest) + +(defrule data-division-head-or-procedure-division-head + := data-division-head + :reduce :data-division + := procedure-division-head + :reduce (list :procedure-division $1)) + +(defrule pp--data-division + := data-division-content procedure-division-head :rest) + +(defrule pp--sentence + := sentence :rest + := :eof) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The real grammar +;;; + +(defrule cobol-source-program + := identification-division environment-division? data-division procedure-division end-program?) + +(defrule identification-division + := identification "DIVISION" "." program-id-cobol-source-program identification-division-content + :reduce program-id-cobol-source-program) + +(defrule priority-number + := integer) + +(defrule level-number + := integer) + +(defrule to-id-or-lit + := "TO" id-or-lit) + +(defrule inspect-by-argument + := variable-identifier + := string + := figurative-constant-simple) + +(defrule figurative-constant-simple + := "ZERO" + :reduce :zero + := "ZEROS" + :reduce :zero + := "ZEROES" + :reduce :zero + := "SPACE" + :reduce :space + := "SPACES" + :reduce :space + := "HIGH-VALUE" + :reduce :high + := "HIGH-VALUES" + :reduce :high + := "LOW-VALUE" + :reduce :low + := "LOW-VALUES" + :reduce :low + := "QUOTE" + :reduce :quote + := "QUOTES" + :reduce :quote + := "NULL" + :reduce :null + := "NULLS" + :reduce :null) + +(defrule write-exceptions + := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?) + +(defrule set-statement-phrase + := variable-identifier+ set-oper set-src) + +(defrule set-src + := variable-identifier + := literal + := "TRUE" + := "ON" + := "OFF") + +(defrule set-oper + := "TO" + :reduce :to + := "UP" "BY" + :reduce :up + := "DOWN" "BY" + :reduce :down) + +(defrule fce-phrase + := reserve-clause + := fce-organization + := fce-access-mode + := record-key-clause + := password-clause + := alternate-record-key-clause + := file-status-clause + := padding-character-clause + := record-delimiter-clause) + +(defrule fce-organization + := organization-is? alt-indexed-relative-sequential + :reduce (list :organization (make-keyword alt-indexed-relative-sequential))) + +(defrule fce-access-mode + := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause? + :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic))) + +(defrule alt-indexed-relative-sequential + := "INDEXED" + := "RELATIVE" + := "SEQUENTIAL") + +(defrule is-not + := "IS"? "NOT"?) + +(defrule all-procedures + := "ALL" "PROCEDURES") + +(defrule next-sentence + := "NEXT" "SENTENCE") + +(defrule no-rewind + := "NO" "REWIND") + +(defrule for-removal + := "FOR"? "REMOVAL") + +(defrule values + := "VALUE" + := "VALUES") + +(defrule records + := "RECORD" + := "RECORDS") + +(defrule end-program + := "END" "PROGRAM" program-name ".") + +(defrule environment-division + := "ENVIRONMENT" "DIVISION" "." environment-division-content) + +(defrule data-division-head + := "DATA" "DIVISION" ".") + +(defrule data-division + := data-division-head data-division-content + :reduce data-division-content) + +(defrule identification + := "IDENTIFICATION" + := "ID") + +(defrule identification-division-content + := identification-division-phrase*) + +(defrule author + := "AUTHOR" ".") + +(defrule installation + := "INSTALLATION" ".") + +(defrule date-written + := "DATE-WRITTEN" ".") + +(defrule date-compiled + := "DATE-COMPILED" ".") + +(defrule security + := "SECURITY" ".") + +(defrule remarks + := "REMARKS" ".") + +(defrule identification-division-phrase + := author + := installation + := date-written + := date-compiled + := security + := remarks) + +(defrule program-id-cobol-source-program + := "PROGRAM-ID" "."? program-name initial-program? "." + :reduce program-name) + +(defrule initial-program + := "IS"? "INITIAL" "PROGRAM"?) + +(defrule environment-division-content + := configuration-section? input-output-section?) + +(defrule input-output-section + := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph? + :reduce file-control-paragraph) + +(defrule file-control-paragraph + := "FILE-CONTROL" "." file-control-entry*) + +(defrule file-control-entry + := select-clause assign-clause fce-phrase* "." + :reduce (append select-clause + assign-clause + (flatten-list fce-phrase))) + +(defrule organization-is + := "ORGANIZATION" "IS"?) + +(defrule alt-sequential-random-dynamic + := "SEQUENTIAL" + := "RANDOM" + := "DYNAMIC") + +(defrule select-clause + := "SELECT" "OPTIONAL"? file-name + :reduce (list file-name :optional (and $2 t))) + +(defrule assign-clause + := "ASSIGN" "TO"? alt-assignment-name-literal+ + :reduce (list :assign alt-assignment-name-literal)) + +(defrule alt-assignment-name-literal + := assignment-name + := literal) + +(defrule reserve-clause + := "RESERVE" integer areas?) + +(defrule areas + := "AREA" + := "AREAS") + +(defrule padding-character-clause + := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal) + +(defrule record-delimiter-clause + := "RECORD" "DELIMITER" "IS"? record-delimiter-name) + +(defrule record-delimiter-name + := "STANDARD-1" + := assignment-name) + +(defrule password-clause + := "PASSWORD" "IS"? data-name) + +(defrule file-status-clause + := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name? + :reduce (list :file-status qualified-data-name)) + +(defrule relative-key-clause + := "RELATIVE" "KEY"? "IS"? qualified-data-name + :reduce (list :relative-key qualified-data-name)) + +(defrule record-key-clause + := "RECORD" "KEY"? "IS"? qualified-data-name + :reduce (list :key qualified-data-name)) + +(defrule alternate-record-key-clause + := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates? + :reduce (list :alternate-key qualified-data-name with-duplicates)) + +(defrule with-duplicates + := "WITH"? "DUPLICATES") + +(defrule i-o-control-paragraph + := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?) + +(defrule i-o-sam + := qsam-or-sam-or-vsam-i-o-control-entries+ ".") + +(defrule i-o-sort-merge + := sort-merge-i-o-control-entries ".") + +(defrule qsam-or-sam-or-vsam-i-o-control-entries + := qsam-or-sam-or-vsam-i-o-control-entries-1 + := qsam-or-sam-or-vsam-i-o-control-entries-2 + := qsam-or-sam-or-vsam-i-o-control-entries-3 + := qsam-or-sam-or-vsam-i-o-control-entries-4) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-1 + := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name) + +(defrule every-phrase-1 + := integer "RECORDS") + +(defrule every-phrase-2 + := "END" "OF"? alt-reel-unit) + +(defrule every-phrase + := every-phrase-1 + := every-phrase-2) + +(defrule alt-assignment-name-file-name + := assignment-name + := file-name) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-2 + := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-3 + := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+) + +(defrule position + := "POSITION" integer) + +(defrule file-name-position + := file-name position?) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-4 + := "APPLY" "WRITE-ONLY" "ON"? file-name+) + +(defrule sort-merge-i-o-control-entries + := rerun-on? same-area+) + +(defrule rerun-on + := "RERUN" "ON" assignment-name) + +(defrule record-sort + := "RECORD" + := "SORT" + := "SORT-MERGE") + +(defrule same-area + := "SAME" record-sort "AREA"? "FOR"? file-name file-name+) + +(defrule configuration-section + := "CONFIGURATION" "SECTION" "." configuration-section-paragraph* + :reduce (flatten-list configuration-section-paragraph)) + +(defrule configuration-section-paragraph + := source-computer-paragraph + := object-computer-paragraph + := special-names-paragraph) + +(defrule source-computer-paragraph + := "SOURCE-COMPUTER" "." source-computer-name + :reduce (list :source-computer source-computer-name)) + +(defrule with-debugging-mode + := "WITH"? "DEBUGGING" "MODE") + +(defrule source-computer-name + := computer-name with-debugging-mode? "." + :reduce computer-name) + +(defrule object-computer-paragraph + := "OBJECT-COMPUTER" "." object-computer-name + :reduce (list :object-computer object-computer-name)) + +(defrule memory-size-type + := "WORDS" + := "CHARACTERS" + := "MODULES") + +(defrule memory-size + := "MEMORY" "SIZE"? integer memory-size-type) + +(defrule object-computer-name + := computer-name memory-size? object-computer-paragraph-sequence-phrase "." + :reduce computer-name) + +(defrule object-computer-paragraph-sequence-phrase + := program-collating-sequence? segment-limit?) + +(defrule program-collating-sequence + := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule segment-limit + := "SEGMENT-LIMIT" "IS"? priority-number) + +(defrule special-names-paragraph + := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "." + :reduce (flatten-list special-names-paragraph-clause)) + +(defrule is-mnemonic-name + := "IS"? mnemonic-name special-names-paragraph-status-phrase?) + +(defrule special-names-paragraph-phrase-tail + := is-mnemonic-name + := special-names-paragraph-status-phrase) + +(defrule special-names-paragraph-phrase + := environment-name special-names-paragraph-phrase-tail) + +(defrule special-names-paragraph-status-phrase + := special-names-paragraph-status-phrase-1 + := special-names-paragraph-status-phrase-2) + +(defrule special-names-paragraph-status-phrase-1 + := "ON" "STATUS"? "IS"? condition off-status?) + +(defrule off-status + := "OFF" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-status-phrase-2 + := "OFF" "STATUS"? "IS"? condition on-status?) + +(defrule on-status + := "ON" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-clause + ;; := alphabet-clause + ;; := symbolic-characters-clause + := currency-sign-clause + := decimal-point-clause) + +(defrule alphabet-clause + := "ALPHABET" alphabet-name "IS"? alphabet-type) + +(defrule alphabet-type-also + := "ALSO" literal) + +(defrule alphabet-type-alsos + := alphabet-type-also+) + +(defrule alphabet-type-also-through + := through-literal + := alphabet-type-alsos) + +(defrule alphabet-type-other + := literal alphabet-type-also-through?) + +(defrule alphabet-type-others + := alphabet-type-other+) + +(defrule alphabet-type + := "STANDARD-1" + := "STANDARD-2" + := "NATIVE" + := "EBCDIC" + := alphabet-type-others) + +(defrule symbolic-characters-clause + := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?) + +(defrule are + := "ARE" + := "IS") + +(defrule symbolic-character-mapping + := symbolic-character+ are? integer+) + +(defrule in-alphabet-name + := "IN" alphabet-name) + +(defrule currency-sign-clause + := "CURRENCY" "SIGN"? "IS"? literal + :reduce (list :currency-sign literal)) + +(defrule decimal-point-clause + := "DECIMAL-POINT" "IS"? "COMMA" + :reduce (list :decimal-point #\,)) + +(defrule data-division-content + := file-section? working-storage-section? linkage-section?) + +(defrule file-section-entry + := file-and-sort-description-entry data-description-entry+ + :reduce (cons file-and-sort-description-entry data-description-entry)) + +(defrule file-section-head + := "FILE" "SECTION" ".") + +(defrule file-section + := file-section-head file-section-entry* + :reduce $2) + +(defrule working-storage-section-head + := "WORKING-STORAGE" "SECTION" ".") + +(defrule working-storage-section + := working-storage-section-head data-description-entry* + :reduce $2) + +(defrule linkage-section-head + := "LINKAGE" "SECTION" ".") + +(defrule linkage-section + := linkage-section-head data-description-entry* + :reduce $2) + +(defrule file-and-sort-description-entry + := alt-fd-sd file-name file-and-sort-description-entry-clause* "." + :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause)) + +(defrule alt-fd-sd + := "FD" + := "SD") + +(defrule file-and-sort-description-entry-clause + := external-clause + := global-clause + := block-contains-clause + := record-clause + := label-records-clause + := value-of-clause + := data-records-clause + := linage-clause + := recording-mode-clause + := code-set-clause) + +(defrule integer-to + := integer "TO") + +(defrule block-contains-clause + := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?) + +(defrule alt-characters-records + := "CHARACTERS" + := "RECORDS" + := "RECORD") + +(defrule record-clause + := "RECORD" record-clause-tail) + +(defrule depending-on + := "DEPENDING" "ON"? data-name) + +(defrule record-clause-tail-1 + := "CONTAINS"? integer "CHARACTERS"?) + +(defrule record-clause-tail-2 + := "CONTAINS"? integer "TO" integer "CHARACTERS"?) + +(defrule record-clause-tail-3 + := record-varying-phrase depending-on?) + +(defrule record-clause-tail + := record-clause-tail-2 + := record-clause-tail-1 + := record-clause-tail-3) + +(defrule record-varying-phrase + := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?) + +(defrule from-integer + := "FROM"? integer) + +(defrule to-integer + := "TO" integer) + +(defrule label-records-clause + := "LABEL" records-are label-records-clause-tail + :reduce (list :label-record label-records-clause-tail)) + +(defrule data-names + := data-name+) + +(defrule label-records-clause-tail + := "STANDARD" :reduce :standard + := "OMITTED" :reduce :omitted + := data-names) + +(defrule value-of-clause + := "VALUE" "OF" value-of-clause-tail+) + +(defrule alt-qualified-data-name-literal + := qualified-data-name + := literal) + +(defrule value-of-clause-tail + := variable-identifier "IS"? alt-qualified-data-name-literal) + +(defrule data-records-clause + := "DATA" records-are data-name+) + +(defrule records-are + := records are?) + +(defrule linage-clause + := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase) + +(defrule linage-footing-phrase + := footing? lines-top? lines-bottom?) + +(defrule alt-data-name-integer + := data-name + := integer) + +(defrule footing + := "WITH"? "FOOTING" "AT"? alt-data-name-integer) + +(defrule lines-top + := "LINES"? "AT"? "TOP" alt-data-name-integer) + +(defrule lines-bottom + := "LINES"? "AT"? "BOTTOM" alt-data-name-integer) + +(defrule recording-mode-clause + := "RECORDING" "MODE"? "IS"? variable-identifier) + +(defrule code-set-clause + := "CODE-SET" "IS"? alphabet-name) + +(defrule data-description-entry + := level-number alt-data-name-filler? data-description-entry-clause* "." + :reduce (append (list level-number alt-data-name-filler) + (flatten-list data-description-entry-clause))) + +(defrule alt-data-name-filler + := data-name + := "FILLER" + :reduce (list)) + +(defrule data-description-entry-clause + := picture-clause + := redefines-clause + := blank-when-zero-clause + := external-clause + := global-clause + := justified-clause + := occurs-clause + := sign-clause + := synchronized-clause + := usage-clause + := renames-clause + := value-clause) + +(defrule value-clause + := "VALUE" "IS"? literal + :reduce (list :value literal)) + +(defrule redefines-clause + := "REDEFINES" data-name + :reduce `(:redefines ,data-name)) + +(defrule blank-when-zero-clause + := "BLANK" "WHEN"? zeroes + :reduce '(:blank-when-zero t)) + +(defrule zeroes + := "ZERO" + := "ZEROS" + := "ZEROES") + +(defrule external-clause + := "IS"? "EXTERNAL" + :reduce '(:external t)) + +(defrule global-clause + := "IS"? "GLOBAL" + :reduce '(:global t)) + +(defrule justified-clause + := justified "RIGHT"? + :reduce `(:justified ,(if $2 :right :left))) + +(defrule justified + := "JUSTIFIED" + := "JUST") + +(defrule occurs-clause + := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times ,integer) + := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times (,integer ,integer2 ,qualified-data-name))) + +(defrule occurs-clause-key + := alt-ascending-descending "KEY"? "IS"? qualified-data-name+) + +(defrule indexed-by + := "INDEXED" "BY"? index-name+) + +(defrule picture-clause + := picture "IS"? picture-string + :reduce `(:picture ,picture-string)) + +(defrule picture + := "PICTURE" + := "PIC") + +(defrule sign-clause + := sign-is? alt-leading-trailing separate-character? + :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing)) + +(defrule sign-is + := "SIGN" "IS"?) + +(defrule separate-character + := "SEPARATE" "CHARACTER"? + :reduce t) + +(defrule alt-leading-trailing + := "LEADING" + :reduce :leading + := "TRAILING" + :reduce :trailing) + +(defrule synchronized-clause + := synchronized alt-left-right? + :reduce `(:synchronized ,(if alt-left-right + alt-left-right + t))) + +(defrule alt-left-right + := "LEFT" + :reduce :left + := "RIGHT" + :reduce :right) + +(defrule synchronized + := "SYNCHRONIZED" + := "SYNC") + +(defrule usage-clause + := usage-is? usage + :reduce (list :encoding usage)) + +(defrule usage-is + := "USAGE" "IS"?) + +(defrule usage + := "BINARY" + :reduce :binary + := "COMP" + :reduce :comp + := "COMP-1" + :reduce :comp1 + := "COMP-2" + :reduce :comp2 + := "COMP-3" + :reduce :comp3 + := "COMP-4" + :reduce :comp4 + := "COMPUTATIONAL" + :reduce :comp + := "COMPUTATIONAL-1" + :reduce :comp1 + := "COMPUTATIONAL-2" + :reduce :comp2 + := "COMPUTATIONAL-3" + :reduce :comp3 + := "COMPUTATIONAL-4" + :reduce :comp4 + := "DISPLAY" + :reduce :display + := "DISPLAY-1" + :reduce :display1 + := "INDEX" + :reduce :index + := "PACKED-DECIMAL" + :reduce :packed-decimal + := "POINTER" + :reduce :pointer) + +(defrule renames-clause + := "RENAMES" qualified-data-name through-qualified-data-name? + :reduce `(:renames ,qualified-data-name ,through-qualified-data-name)) + +(defrule through-qualified-data-name + := through qualified-data-name + :reduce qualified-data-name) + +(defrule condition-value-clause + := values-are literal-through-literal+) + +(defrule through-literal + := through literal) + +(defrule literal-through-literal + := literal through-literal?) + +(defrule values-are + := values are?) + +(defrule procedure-division-head + := "PROCEDURE" "DIVISION" using-phrase? ".") + +(defrule procedure-division + := procedure-division-head sentence+) + +(defrule using-phrase + := "USING" data-name+) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule declaratives + := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".") + +(defrule declaratives-content + := cobol-identifier "SECTION" "." use-statement "." sentence*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule paragraph-header + := cobol-identifier "SECTION"? + :reduce (list (if $2 :section :label) $1)) + +(defrule sentence + := declaratives + := statement* "." + :reduce $1 + := paragraph-header "." + :reduce $1) + +(defrule statement + := move-statement + := if-statement + := perform-statement + := go-to-statement + := accept-statement + := add-statement + := alter-statement + := call-statement + := cancel-statement + := close-statement + := compute-statement + := continue-statement + := delete-statement + := display-statement + := divide-statement + := entry-statement + := evaluate-statement + := exit-program-statement + := exit-statement + := goback-statement + := initialize-statement + := inspect-statement + := merge-statement + := multiply-statement + := open-statement + := read-statement + := release-statement + := return-statement + := rewrite-statement + := search-statement + := set-statement + := sort-statement + := start-statement + := stop-statement + := string-statement + := subtract-statement + := unstring-statement + := write-statement + := paragraph-header) + +(defrule accept-statement + := "ACCEPT" variable-identifier "FROM" date + := "ACCEPT" variable-identifier "AT" screen-coordinates + :reduce (apply #'list 'accept-at variable-identifier screen-coordinates) + := "ACCEPT" variable-identifier from-environment-name?) + +(defrule from-environment-name + := "FROM" cobol-identifier) + + +(defrule date + := "DATE" + := "DAY" + := "DAY-OF-WEEK" + := "TIME") + +(defrule add-statement + := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?) + +(defrule statement-list + := statement+) + +(defrule alter-statement + := "ALTER" procedure-to-procedure+) + +(defrule proceed-to + := "PROCEED" "TO") + +(defrule procedure-to-procedure + := procedure-name "TO" proceed-to? procedure-name) + +(defrule call-statement + := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"? + :reduce (list 'call id-or-lit (cons 'list using-parameters))) + +(defrule by-reference + := "BY"? "REFERENCE") + +(defrule content-parameter-value + := cobol-identifier + := literal) + +(defrule reference-parameter + := by-reference? variable-identifier) + +(defrule content-parameter + := "BY"? "CONTENT" content-parameter-value+) + +(defrule parameter + := reference-parameter + := content-parameter + := literal) + +(defrule using-parameters + := "USING" parameter+) + +(defrule call-rest-phrase + := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?) + +(defrule on-exception-statement-list + := "ON"? "EXCEPTION" statement-list) + +(defrule not-on-exception-statement-list + := "NOT" "ON"? "EXCEPTION" statement-list) + +(defrule cancel-statement + := "CANCEL" id-or-lit+) + +(defrule close-statement + := "CLOSE" close-statement-file-name+ + :reduce (list 'close close-statement-file-name)) + +(defrule alt-removal-no-rewind + := for-removal + := with-no-rewind) + +(defrule alt-reel-unit + := "REEL" + := "UNIT") + +(defrule alt-no-rewind-lock + := no-rewind + := "LOCK") + +(defrule close-statement-options-1 + := alt-reel-unit alt-removal-no-rewind?) + +(defrule close-statement-options-2 + := "WITH"? alt-no-rewind-lock) + +(defrule close-statement-options + := close-statement-options-1 + := close-statement-options-2) + +(defrule close-statement-file-name + := file-name close-statement-options?) + +(defrule compute-statement + := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"? + :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule equal + := "=" + := "EQUAL") + +(defrule continue-statement + := "CONTINUE") + +(defrule delete-statement + := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"? + :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list)) + +(defrule display-statement + := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing? + :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing)) + := "DISPLAY" id-or-lit "AT" screen-coordinates + :reduce (apply #'list 'display-at id-or-lit screen-coordinates)) + +(defrule screen-coordinates + := integer + :reduce (multiple-value-list (truncate integer 100))) + +(defrule upon-environment-name + := "UPON" cobol-identifier) + +(defrule with-no-advancing + := "WITH"? "NO" "ADVANCING") + +(defrule divide-statement + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?) + +(defrule entry-statement + := "ENTRY" literal using-phrase?) + +(defrule evaluate-statement + := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?) + +(defrule evaluate-condition + := condition + := "TRUE" + := "FALSE") + +(defrule also-phrase + := "ALSO" evaluate-condition) + +(defrule when-phrase-also-phrase + := "ALSO" evaluate-phrase) + +(defrule when-phrase + := "WHEN" evaluate-phrase when-phrase-also-phrase*) + +(defrule when-phrases + := when-phrase+ statement-list) + +(defrule when-other-phrase + := "WHEN" "OTHER" statement-list) + +(defrule evaluate-phrase + := "ANY" + := condition + := "TRUE" + := "FALSE" + := evaluate-phrase-1) + +(defrule evaluate-phrase-1 + := "NOT"? arithmetic-expression through-arithmetic-expression?) + +(defrule through-arithmetic-expression + := through arithmetic-expression) + +(defrule exit-statement + := "EXIT" + :reduce '(exit-paragraph)) + +(defrule exit-program-statement + := "EXIT" "PROGRAM" + :reduce '(exit-program)) + +(defrule goback-statement + := "GOBACK" + :reduce '(go-back)) + +(defrule go-to-statement + := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier + :reduce (list 'goto-depending variable-identifier procedure-name) + := "GO" "TO"? procedure-name + :reduce (list 'goto procedure-name)) + +(defrule if-phrase + := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence + :reduce (list 'if condition + (if (cdr alt-statement-list-next-sentence) + (cons 'progn alt-statement-list-next-sentence) + (car alt-statement-list-next-sentence)) + (if (cdr alt-statement-list-next-sentence2) + (cons 'progn alt-statement-list-next-sentence2) + (car alt-statement-list-next-sentence2))) + := "IF" condition "THEN"? alt-statement-list-next-sentence + :reduce (append (list 'when condition) alt-statement-list-next-sentence)) + +(defrule if-statement + := if-phrase "END-IF"? + :reduce $1) + +(defrule initialize-statement + := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?) + +(defrule initialize-replacing-type + := "ALPHABETIC" + := "ALPHANUMERIC" + := "NUMERIC" + := "ALPHANUMERIC-EDITED" + := "NUMERIC-EDITED" + := "DBCS" + := "EGCS") + +(defrule initialize-replacing-argument + := initialize-replacing-type "DATA"? "BY" id-or-lit) + +(defrule initialize-replacing-phrase + := "REPLACING" initialize-replacing-argument+) + +(defrule inspect-statement + := inspect-statement-1 + := inspect-statement-2 + := inspect-statement-3 + := inspect-statement-4) + +(defrule inspect-statement-1 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+) + +(defrule inspect-statement-2 + := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*) + +(defrule inspect-statement-3 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+) + +(defrule tallying-for-id-or-lit + := id-or-lit before-after-phrase*) + +(defrule alt-all-leading + := "ALL" + := "LEADING") + +(defrule tallying-for-argument-1 + := "CHARACTERS" before-after-phrase*) + +(defrule tallying-for-argument-2 + := alt-all-leading tallying-for-id-or-lit+) + +(defrule tallying-for-argument + := tallying-for-argument-1 + := tallying-for-argument-2) + +(defrule tallying-argument + := variable-identifier "FOR" tallying-for-argument+) + +(defrule inspect-statement-4 + := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+) + +(defrule inspect-replacing-argument + := inspect-by-argument "BY" inspect-by-argument before-after-phrase*) + +(defrule alt-all-leading-first + := "ALL" + := "LEADING" + := "FIRST") + +(defrule inspect-replacing-phrase-1 + := "CHARACTERS" "BY" id-or-lit before-after-phrase*) + +(defrule inspect-replacing-phrase-2 + := alt-all-leading-first inspect-replacing-argument+) + +(defrule inspect-replacing-phrase + := inspect-replacing-phrase-1 + := inspect-replacing-phrase-2) + +(defrule before-after-phrase + := alt-before-after "INITIAL"? id-or-lit) + +(defrule merge-statement + := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail) + +(defrule on-key-phrase + := "ON"? alt-ascending-descending "KEY"? qualified-data-name+) + +(defrule merge-statement-tail + := output-procedure + := giving-file-names) + +(defrule move-statement + := "MOVE" id-or-lit "TO" variable-identifier+ + :reduce (apply #'list 'move id-or-lit variable-identifier) + := "MOVE" corresponding variable-identifier "TO" variable-identifier+ + :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2)) + +(defrule multiply-statement + := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule open-statement + := "OPEN" open-statement-phrase+ + :reduce (list 'open open-statement-phrase)) + +(defrule alt-reversed-with-no-rewind + := "REVERSED" + := with-no-rewind) + +(defrule open-statement-input-file-name + := file-name alt-reversed-with-no-rewind?) + +(defrule with-no-rewind + := "WITH"? "NO" "REWIND") + +(defrule open-statement-output-file-name + := file-name with-no-rewind?) + +(defrule open-statement-input + := "INPUT" open-statement-input-file-name+) + +(defrule open-statement-output + := "OUTPUT" open-statement-output-file-name+) + +(defrule open-statement-i-o + := "I-O" file-name+) + +(defrule open-statement-extend + := "EXTEND" file-name+) + +(defrule open-statement-phrase + := open-statement-input + := open-statement-output + := open-statement-i-o + := open-statement-extend) + +(defrule perform-statement + := "PERFORM" procedure-name through-procedure-name? perform-until-phrase + :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase) + := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase* + :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase) + := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES" + :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name) + := "PERFORM" procedure-name through-procedure-name? + :reduce (append (list 'perform procedure-name) through-procedure-name)) + +(defrule perform-varying-phrase + := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-after-phrase + := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-until-phrase + := with-test? "UNTIL" condition) + +(defrule with-test + := "WITH"? "TEST" alt-before-after + :reduce alt-before-after) + +(defrule read-statement + := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?) + +(defrule key-is-qualified-data-name + := "KEY" "IS"? qualified-data-name) + +(defrule release-statement + := "RELEASE" record-name from-identifier?) + +(defrule return-statement + := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?) + +(defrule into-identifier + := "INTO" variable-identifier) + +(defrule not-at-end-statement-list + := "NOT" "AT"? "END" statement-list) + +(defrule rewrite-statement + := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?) + +(defrule search-statement + := search-statement-1 + := search-statement-2) + +(defrule search-statement-1 + := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?) + +(defrule varying-identifier + := "VARYING" variable-identifier) + +(defrule when-condition-stats + := "WHEN" condition alt-statement-list-next-sentence) + +(defrule search-statement-2 + := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?) + +(defrule at-end-statement-list + := "AT"? "END" statement-list) + +(defrule search-statement-equal-expression + := variable-identifier "IS"? equal-to arithmetic-expression + :reduce (list '= variable-identifier arithmetic-expression)) + +(defrule search-statement-condition + := search-statement-equal-expression + := condition-name-reference) + +(defrule search-statement-condition-tail + := "AND" search-statement-condition) + +(defrule alt-statement-list-next-sentence + := statement+ + := next-sentence + :reduce :next-sentence) + +(defrule set-statement + := "SET" set-statement-phrase+) + +(defrule sort-statement + := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out) + +(defrule key-is + := "KEY" "IS"?) + +(defrule alt-ascending-descending + := "ASCENDING" + := "DESCENDING") + +(defrule on-key-is-phrase + := "ON"? alt-ascending-descending key-is? qualified-data-name+) + +(defrule with-duplicates-in-order + := "WITH"? "DUPLICATES" "IN"? "ORDER"?) + +(defrule collating-sequence + := "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule through + := "THROUGH" + := "THRU") + +(defrule through-procedure-name + := through procedure-name + :reduce procedure-name) + +(defrule using-file-names + := "USING" file-name+) + +(defrule input-procedure + := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule giving-file-names + := "GIVING" file-name+) + +(defrule output-procedure + := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule sort-statement-in + := using-file-names + := input-procedure) + +(defrule sort-statement-out + := giving-file-names + := output-procedure) + +(defrule start-statement + := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?) + +(defrule rel-op + := equal-to + :reduce '= + := greater-than + :reduce '> + := greater-equal + :reduce '>=) + +(defrule key-is-rel-op-qualified-data-name + := "KEY" "IS"? rel-op qualified-data-name + :reduce (list rel-op qualified-data-name)) + +(defrule stop-statement + := "STOP" alt-run-literal + :reduce '(stop)) + +(defrule alt-run-literal + := "RUN" + := literal) + +(defrule string-statement + := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"? + :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit-size + := literal + := variable-identifier + := "SIZE") + +(defrule delimited-by-phrase + := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size + :reduce (list id-or-lit id-or-lit-size)) + +(defrule subtract-statement + := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract id-or-lit cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-corr variable-identifier variable-identifier + :rounded (and $5 t) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule cobword-rounded + := variable-identifier "ROUNDED"? + :reduce (list variable-identifier (and $2 t))) + +(defrule on-size-error-statement-list + := "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule not-on-size-error-statement-list + := "NOT" "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule corresponding + := "CORRESPONDING" + := "CORR") + +(defrule unstring-statement + := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"? + :reduce (list 'unstring variable-identifier unstring-statement-dst + :delimited-by-all delimited-by-all-phrase + :with-pointer with-pointer-identifier + :tallying tallying-in-identifier + :on-overflow on-overflow-statement-list + :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit + := literal + := variable-identifier) + +(defrule or-all-id-or-lit + := "OR" "ALL"? id-or-lit) + +(defrule delimited-by-all-phrase + := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*) + +(defrule delimiter-in-identifier + := "DELIMITER" "IN"? variable-identifier) + +(defrule count-in-identifier + := "COUNT" "IN"? variable-identifier) + +(defrule unstring-statement-dst + := variable-identifier delimiter-in-identifier? count-in-identifier?) + +(defrule with-pointer-identifier + := "WITH"? "POINTER" variable-identifier) + +(defrule tallying-in-identifier + := "TALLYING" "IN"? variable-identifier) + +(defrule on-overflow-statement-list + := "ON"? "OVERFLOW" statement-list) + +(defrule not-on-overflow-statement-list + := "NOT" "ON"? "OVERFLOW" statement-list) + +(defrule write-statement + := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?) + +(defrule lines + := "LINE" + := "LINES") + +(defrule cobword-int + := cobol-identifier + := integer) + +(defrule nr-lines-phrase + := cobword-int lines?) + +(defrule page-phrase + := nr-lines-phrase + := "PAGE") + +(defrule alt-before-after + := "BEFORE" + := "AFTER") + +(defrule advancing-phrase + := alt-before-after "ADVANCING"? page-phrase) + +(defrule from-identifier + := "FROM" variable-identifier) + +(defrule invalid-key-statement-list + := "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule not-invalid-key-statement-list + := "NOT" "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule end-of-page + := "END-OF-PAGE" + := "EOP") + +(defrule at-end-of-page-statement-list + := "AT"? end-of-page statement-list + :reduce statement-list) + +(defrule not-at-end-of-page-statement-list + := "NOT" "AT"? end-of-page statement-list + :reduce statement-list) + +;; This is left in the grammar but is not used. COPYs are handled by +;; the lexical scanner. +(defrule copy-statement + := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?) + +(defrule in + := "OF" + := "IN") + +(defrule alt-library-name-literal + := library-name + := literal) + +(defrule in-library + := in alt-library-name-literal) + +(defrule copy-statement-by-phrase + := copy-operand "BY" copy-operand) + +(defrule copy-statement-replacing-phrase + := "REPLACING" copy-statement-by-phrase+) + +(defrule alt-text-name-literal + := text-name + := literal) + +(defrule copy-operand + := cobol-identifier + := literal) + +(defrule use-statement + := use-statement-1 + := use-statement-2 + := use-statement-3) + +(defrule use-statement-1 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-exception-error + := "EXCEPTION" + := "ERROR") + +(defrule use-statement-2 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-beginning-ending + := "BEGINNING" + := "ENDING") + +(defrule alt-file-reel-unit + := "FILE" + := "REEL" + := "UNIT") + +(defrule file-names + := file-name+) + +(defrule alt-file-names-i-o + := file-names + := "INPUT" + := "OUTPUT" + := "I-O" + := "EXTEND") + +(defrule use-statement-3 + := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures) + +(defrule procedure-names + := procedure-name+) + +(defrule alt-procedures-all-procedures + := procedure-names + := all-procedures) + +(defrule condition + := combinable-condition + := combinable-condition "AND" condition + :reduce `(and ,combinable-condition ,condition) + := combinable-condition "OR" condition + :reduce `(or ,combinable-condition ,condition) + := combinable-condition "AND" id-or-lit + :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)) + := combinable-condition "OR" id-or-lit + :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))) + +(defrule combinable-condition + := "NOT"? simple-condition + :reduce (if $1 + (list 'not simple-condition) + simple-condition)) + +(defrule simple-condition + := class-condition + := relation-condition + := sign-condition + := "(" condition ")" + ;; not sure if it's necessary -wcp15/7/03. + ;; := arithmetic-expression + ) + +(defrule class-condition + := variable-identifier "IS"? "NOT"? class-type + :reduce (if $3 + (list 'not (list 'type-of variable-identifier (make-keyword class-type))) + (list 'type-of variable-identifier (make-keyword class-type)))) + +(defrule class-type + := "NUMERIC" + := "ALPHABETIC" + := "ALPHABETIC-LOWER" + := "ALPHABETIC-UPPER" + := "DBCS") + +(defun unfold-subrelations (main-relation subs) + (destructuring-bind (main-operator main-variable other-variable) main-relation + (declare (ignore other-variable)) + (labels ((unfold (subs) + (if (null subs) + main-relation + (destructuring-bind (connection operator variable) (car subs) + (list connection + (list (or operator main-operator) main-variable variable) + (unfold (cdr subs))))))) + (unfold subs)))) + +(defrule relation-condition + ;; This is too complex + ;; := arithmetic-expression relational-operator simple-condition + := id-or-lit relational-operator id-or-lit subordinate-relation* + :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation)) + +(defrule or-and + := "OR" :reduce 'or + := "AND" :reduce 'and) + +(defrule subordinate-relation + := or-and relational-operator? id-or-lit + :reduce (list or-and relational-operator id-or-lit)) + +(defrule relational-operator + := "IS"? relational-operator-type + :reduce relational-operator-type) + +(defrule less-than + := "LESS" "THAN"? + := "<") + +(defrule greater-equal + := "GREATER" "THAN"? "OR" "EQUAL" "TO"? + := ">=" + := ">" "=" + := "NOT" "<" + := "NOT" "LESS" "THAN"?) + +(defrule less-equal + := "LESS" "THAN"? "OR" "EQUAL" "TO"? + := "<=" + := "<" "=" + := "NOT" ">" + := "NOT" "GREATER" "THAN"?) + +(defrule greater-than + := "GREATER" "THAN"? + := ">") + +(defrule equal-to + := "EQUAL" "TO"? + := "=") + +(defrule relational-operator-type + := greater-equal + :reduce 'cob>= + := less-equal + :reduce 'cob<= + := greater-than + :reduce 'cob> + := less-than + :reduce 'cob< + := equal-to + :reduce 'cob= + := "NOT" equal-to + :reduce 'cob-not=) + +(defrule sign-condition + := arithmetic-expression "IS"? "NOT"? sign-type + :reduce (if $3 + `(not (,sign-type ,arithmetic-expression)) + `(,sign-type ,arithmetic-expression))) + +(defrule sign-type + := "POSITIVE" :reduce '> + := "NEGATIVE" :reduce '< + := "ZERO" :reduce '= + := "ZEROES" :reduce '= + := "ZEROS" :reduce '=) + +(defrule procedure-name + := paragraph-or-section-name in-section-name + :reduce (list paragraph-or-section-name in-section-name) + := paragraph-or-section-name + :reduce paragraph-or-section-name) + +(defrule in-section-name + := in cobol-identifier + :reduce cobol-identifier) + +(defrule variable-identifier + := qualified-data-name subscript-parentheses* ;; reference-modification? + :reduce (if subscript-parentheses + (list :aref qualified-data-name subscript-parentheses) + qualified-data-name)) + +(defrule reference-modification + := "(" leftmost-character-position ":" length? ")" + :reduce (if length + (list :range leftmost-character-position length) + leftmost-character-position)) + +(defrule condition-name-reference + := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*) + +(defrule in-data-or-file-or-mnemonic-name + := in data-or-file-or-mnemonic-name) + +(defrule subscript-parentheses + := "(" subscript ")") + +(defrule subscript + := subscript-expression+) + +(defrule plus-minus-integer + := plus-or-minus integer) + +(defrule subscript-expression-ambiguous + := qualified-data-name plus-minus-integer?) + +(defrule subscript-expression + := literal + := subscript-expression-ambiguous) + +(defrule qualified-data-name + := data-name in-data-or-file-name* + :reduce (if in-data-or-file-name + (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. + data-name) + := "ADDRESS" "OF" data-name + :reduce (list 'address-of data-name) + := "LENGTH" "OF" cobol-identifier + :reduce (list 'length-of cobol-identifier)) + +(defrule in-data-or-file-name + := in data-or-file-name) + +(defrule leftmost-character-position + := arithmetic-expression) + +(defrule length + := arithmetic-expression) + +(defrule arithmetic-expression + := times-div + := times-div "+" arithmetic-expression + :reduce `(+ ,times-div ,arithmetic-expression) + := times-div "-" arithmetic-expression + :reduce `(- ,times-div ,arithmetic-expression)) + +(defrule times-div + := power + := power "*" times-div + :reduce `(* ,power ,times-div) + := power "/" times-div + :reduce `(/ ,power ,times-div)) + +(defrule power + := plus-or-minus? basis + := plus-or-minus? basis "**" power + :reduce (if plus-or-minus + `(plus-or-minus (expt basis basis2)) + `(expt basis basis2))) + +(defrule plus-or-minus + := "+" + :reduce '+ + := "-" + :reduce '-) + +;; (defrule power-tail +;; := "**" basis) + +(defrule basis + := literal + := variable-identifier + := "(" arithmetic-expression ")") + +(defrule alphabet-name + := cobol-identifier) + +(defrule condition-name + := cobol-identifier) + +(defrule data-name + := cobol-identifier) + +(defrule cobol-identifier + := identifier + :reduce (intern (string-upcase identifier))) + +(defrule file-name + := cobol-identifier) + +(defrule data-or-file-name + := cobol-identifier) + +(defrule index-name + := cobol-identifier) + +(defrule mnemonic-name + := cobol-identifier) + +(defrule data-or-file-or-mnemonic-name + := cobol-identifier) + +(defrule record-name + := qualified-data-name) + +(defrule symbolic-character + := cobol-identifier) + +(defrule library-name + := cobol-identifier) + +(defrule program-name + := cobol-identifier + := string) + +(defrule text-name + := cobol-identifier) + +(defrule paragraph-or-section-name + := cobol-identifier + := integer) + +(defrule computer-name + := identifier) + +(defrule environment-name + := cobol-identifier) + +(defrule assignment-name + := cobol-identifier) + +(defrule figurative-constant + := figurative-constant-simple + := figurative-constant-all) + +(defrule figurative-constant-all + := "ALL" literal) + +(defrule literal + := string + := float + := integer + := figurative-constant) + +) ; defun populate-grammar diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd new file mode 100644 index 000000000000..addb7c6932af --- /dev/null +++ b/third_party/lisp/npg/npg.asd @@ -0,0 +1,55 @@ +;;; npg.asd --- declaration of this system + +;;; Copyright (C) 2003, 2006 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: npg.asd, Time-stamp: <2006-01-03 17:20:21 wcp> $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :npg-system + (:use :common-lisp :asdf)) + +(in-package :npg-system) + +(defclass sample-file (doc-file) ()) +(defmethod source-file-type ((c sample-file) (s module)) + "lisp") + +(defsystem npg + :name "NPG" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :licence "Lesser General Public License" + :description "NPG a Naive Parser Generator" + :long-description + "NPG is a backtracking recursive descent parser generator for +Common Lisp. It accepts rules in a Lispy EBNF syntax without indirect +left recursive rules." + :components + ((:doc-file "README") + (:doc-file "COPYING") + (:doc-file ".project") + (:module :examples + :components + ((:sample-file "python") + (:sample-file "vs-cobol-ii"))) + (:module :src + :components + ((:file "package") + (:file "common" :depends-on ("package")) + (:file "define" :depends-on ("package" "common")) + (:file "parser" :depends-on ("package" "common")))))) diff --git a/third_party/lisp/npg/src/common.lisp b/third_party/lisp/npg/src/common.lisp new file mode 100644 index 000000000000..8b64f5cc0a7b --- /dev/null +++ b/third_party/lisp/npg/src/common.lisp @@ -0,0 +1,79 @@ +;;; common.lisp --- common stuff + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: common.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +(eval-when (:compile-toplevel :load-toplevel) + (defstruct grammar + rules + keywords + equal-p) + + (defstruct rule + name + productions) + + (defstruct (production (:conc-name prod-)) + tokens + (tokens-length 0 :type fixnum) + action) + + (defstruct token + type ; type of token (identifier, number, ...) + value ; its actual value + position) ; line/column in the input stream + ) ; eval-when + +(defmethod print-object ((obj rule) stream) + (format stream "#R(~A)" (rule-name obj))) + +(defmethod print-object ((obj production) stream) + (format stream "#P(action: ~S)" (prod-action obj))) + +(defmethod print-object ((obj token) stream) + (format stream "#T:~A=~S" (token-type obj) (token-value obj))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-rules-table find-rule add-rule)) + +(defun make-rules-table () + (make-hash-table)) + +(defun find-rule (rule-name rules) + (gethash rule-name rules)) + +(defun add-rule (rule-name rule rules) + (setf (gethash rule-name rules) rule)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-keywords-table find-keyword add-keyword)) + +(defun make-keywords-table () + (make-hash-table :test 'equal)) + +(defun find-keyword (keyword-name keywords) + (gethash keyword-name keywords)) + +(defun add-keyword (keyword keywords) + (setf (gethash keyword keywords) t)) diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp new file mode 100644 index 000000000000..f52f0381a2de --- /dev/null +++ b/third_party/lisp/npg/src/define.lisp @@ -0,0 +1,408 @@ +;;; define.lisp --- grammar rules definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: define.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *smart-default-reduction* t + "If true the default reductions take only the non-static tokens - +those that are not declared as strings in the grammar.") + +;; These two are filled with DEFRULE. +(defvar *rules* (make-rules-table)) +(defvar *keywords* (make-keywords-table)) + +(defun make-action-arguments (tokens) + "Given a list of tokens making up a production, return three values: +the list of variables for the function reducing this production, those +that are non static and their unambiguous user-friendly names." + (flet ((unique (sym list) + (if (not (assoc sym list)) + sym + (loop + for i of-type fixnum from 2 + for x = (intern (format nil "~:@(~A~)~A" sym i)) + while (assoc x list) + finally (return x))))) + (loop + for tok in tokens + for i of-type fixnum from 1 + for arg = (intern (format nil "$~A" i) (find-package #.*package*)) + collect arg into args + unless (const-terminal-p tok) + collect arg into vars + and when (symbolp tok) + collect (list (unique tok named-vars) arg) into named-vars + when (and (listp tok) + (symbolp (cadr tok))) + collect (list (unique (cadr tok) named-vars) arg) into named-vars + finally + (return (values args vars named-vars))))) + +(defun make-action-function (name tokens action) + "Create a function with name NAME, arguments derived from TOKENS and +body ACTION. Return it's definition." + (let ((function + (multiple-value-bind (args vars named-vars) + (make-action-arguments tokens) + `(lambda ,args + (declare (ignorable ,@args)) + (let (($vars (list ,@vars)) + ($all (list ,@args)) + ,@named-vars + ($alist (list ,@(mapcar #'(lambda (v) + `(cons ',(intern (symbol-name (car v))) + ,(cadr v))) + named-vars)))) + (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) + (flet ((make-object (&optional type args) + (apply #'make-instance (or type ',name) + (append args $alist)))) + ,action)))))) + (when *compile-print* + (if *compile-verbose* + (format t "; Compiling ~S:~% ~S~%" name function) + (format t "; Compiling ~S~%" name))) + (compile name function))) + +(defun define-rule (name productions) + "Accept a rule in EBNF-like syntax, translate it into a sexp and a +call to INSERT-RULE-IN-CURRENT-GRAMMAR." + (flet ((transform (productions) + (loop + for tok in productions + with prod = nil + with action = nil + with phase = nil + with new-prods = nil + while tok + do (cond ((eq tok :=) + (push (list (nreverse prod) action) new-prods) + (setf prod nil + action nil + phase :prod)) + ((eq tok :reduce) + (setf phase :action)) + ((eq tok :tag) + (setf phase :tag)) + ((eq phase :tag) + (setf action `(cons ,tok $vars))) + ((eq phase :action) + (setf action tok)) + ((eq phase :prod) + (push tok prod))) + finally + (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) + (insert-rule-in-current-grammar name (transform productions)))) + +(defmacro defrule (name &rest productions) + "Wrapper macro for DEFINE-RULE." + `(define-rule ',name ',productions)) + +(defun make-optional-rule (token) + "Make a rule for a possibly missing (non)terminal (? syntax) and +return it." + (insert-rule-in-current-grammar + (gensym (concatenate 'string "OPT-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))) + `(((,token)) (())))) + +(defun make-alternative-rule (tokens) + "Make a rule for a list of alternatives (\"or\" syntax) and return it." + (insert-rule-in-current-grammar + (gensym "ALT") + (mapcar #'(lambda (alternative) + `((,alternative))) + tokens))) + +(defun make-nonempty-list-rule (token &optional separator) + "Make a rule for a non-empty list (+ syntax) and return it." + (let ((rule-name (gensym (concatenate 'string "NELST-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))))) + (insert-rule-in-current-grammar + rule-name + (if separator + `(((,token ,separator ,rule-name) + (cons $1 $3)) + ((,token) ,#'list)) + `(((,token ,rule-name) + (cons $1 $2)) + ((,token) ,#'list)))))) + +(defun make-list-rule (token &optional separator) + "Make a rule for a possibly empty list (* syntax) return it." + (make-optional-rule (make-nonempty-list-rule token separator))) + +(defun const-terminal-p (object) + (or (stringp object) + (keywordp object))) + +(defun expand-production-token (tok) + "Translate token of the type NAME? or NAME* or NAME+ into (? NAME) +or (* NAME) or (+ NAME). This is used by the DEFRULE macro." + (if (symbolp tok) + (let* ((name (symbol-name tok)) + (last (char name (1- (length name)))) + ;; this looks silly but we need to make sure that we + ;; return symbols interned in this package, no one else + (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) + (if (and (> (length name) 1) op) + (list op + (intern (subseq name 0 (1- (length name))))) + tok)) + tok)) + +(defun EBNF-to-SEBNF (tokens) + "Take a production as a list of TOKENS and expand it. This turns a +EBNF syntax into a sexp-based EBNF syntax or SEBNF." + (loop + for tok in tokens + for token = (expand-production-token tok) + with new-tokens = '() + do (cond ((member token '(* + ?)) + (setf (car new-tokens) + (list token (car new-tokens)))) + (t + (push token new-tokens))) + finally (return (nreverse new-tokens)))) + +(defun SEBNF-to-BNF (tokens) + "Take a production in SEBNF (Symbolic Extended BNF) syntax and turn +it into BNF. The production is simplified but the current grammar is +populated with additional rules." + (flet ((make-complex-token-rule (tok) + (ecase (car tok) + (* (apply #'make-list-rule (cdr tok))) + (+ (apply #'make-nonempty-list-rule (cdr tok))) + (? (make-optional-rule (cadr tok))) + (or (make-alternative-rule (cdr tok)))))) + (loop + for token in tokens + with new-tokens = '() + with keywords = '() + do (cond ((listp token) + (push (make-complex-token-rule token) new-tokens)) + (t + (push token new-tokens) + (when (const-terminal-p token) + (push token keywords)))) + finally (return (values (nreverse new-tokens) keywords))))) + +(defun make-default-action-function (name tokens) + "Create a sexp to be used as default action in case one is not +supplied in the production. This is usually a quite sensible +one. That is, only the non-constant tokens are returned in a +list and in case only a variable token is available that one is +returned (not included in a list). If all the tokens are +constant, then all of them are returned in a list." + (cond ((null tokens) + ;; if the production matched the empty list (no tokens) we + ;; return always nil, that is the function LIST applied to no + ;; arguments + #'list) + ((null (cdr tokens)) + ;; if the production matches just one token we simply return + ;; that + #'identity) + (*smart-default-reduction* + ;; If we are required to be "smart" then create a function + ;; that simply returns the non static tokens of the + ;; production. If the production doesn't have nonterminal, + ;; then return all the tokens. If the production has only + ;; one argument then return that one only. + (make-action-function name tokens '(cond + ((null $vars) $all) + ((null (cdr $vars)) (car $vars)) + (t $vars)))) + (t + ;; in all the other cases we return all the token matching + ;; the production + #'list))) + +(defun make-production-from-descr (name production-description) + "Take a production NAME and its description in the form of a sexp +and return a production structure object together with a list of used +keywords." + (destructuring-bind (tokens &optional action) production-description + (let ((expanded-tokens (EBNF-to-SEBNF tokens))) + (multiple-value-bind (production-tokens keywords) + (sebnf-to-bnf expanded-tokens) + (let ((funct + (cond ((not action) + (make-default-action-function name expanded-tokens)) + ((or (listp action) + ;; the case when the action is simply to + ;; return a token (ie $2) or a constant value + (symbolp action)) + (make-action-function name expanded-tokens action)) + ((functionp action) + action) + (t ; action is a constant + #'(lambda (&rest args) + (declare (ignore args)) + action))))) + (values + ;; Make a promise instead of actually resolving the + ;; nonterminals. This avoids endless recursion. + (make-production :tokens production-tokens + :tokens-length (length production-tokens) + :action funct) + keywords)))))) + +(defun remove-immediate-left-recursivity (rule) + "Turn left recursive rules of the type + A -> A x | y +into + A -> y A2 + A2 -> x A2 | E +where E is the empty production." + (let ((name (rule-name rule)) + (productions (rule-productions rule))) + (loop + for prod in productions + for tokens = (prod-tokens prod) + ;; when immediately left recursive + when (eq (car tokens) rule) + collect prod into left-recursive + else + collect prod into non-left-recursive + finally + ;; found any left recursive production? + (when left-recursive + (warn "rule ~S is left recursive" name) + (let ((new-rule (make-rule :name (gensym "REWRITE")))) + ;; A -> y A2 + (setf (rule-productions rule) + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append tokens (list new-rule)) + :tokens-length (1+ (prod-tokens-length p)) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + (funcall f-A2 (apply action head))))))) + non-left-recursive)) + ;; A2 -> x A2 | E + (setf (rule-productions new-rule) + (append + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append (cdr tokens) (list new-rule)) + :tokens-length (prod-tokens-length p) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + #'(lambda (x) + (funcall f-A2 (apply action x head)))))))) + left-recursive) + (list + (make-production :tokens nil + :tokens-length 0 + :action #'(lambda () #'(lambda (arg) arg))))))))))) + +(defun remove-left-recursivity-from-rules (rules) + (loop + for rule being each hash-value in rules + do + ;; More to be done here. For now only the trivial immediate left + ;; recursivity is removed -wcp18/11/03. + (remove-immediate-left-recursivity rule))) + +(defun resolve-all-nonterminals (rules) + (loop + for rule being each hash-value in rules + do (loop + for production in (rule-productions rule) + do (setf (prod-tokens production) + (resolve-nonterminals (prod-tokens production) rules))))) + +(defun make-rule-productions (rule-name production-descriptions) + "Return a production object that belongs to RULE-NAME made according +to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR." + (loop + for descr in production-descriptions + for i of-type fixnum from 1 by 1 + for prod-name = (intern (format nil "~:@(~A~)-PROD~A" rule-name i)) + with productions = '() + with keywords = '() + do (progn + (multiple-value-bind (production keyws) + (make-production-from-descr prod-name descr) + (push production productions) + (setf keywords (append keyws keywords)))) + finally (return + (values (nreverse productions) keywords)))) + +(defun create-rule (name production-descriptions) + "Return a new rule object together with a list of keywords making up +the production definitions." + (multiple-value-bind (productions keywords) + (make-rule-productions name production-descriptions) + (values (make-rule :name name :productions productions) + keywords))) + +(defun insert-rule-in-current-grammar (name productions) + "Add rule to the current grammar and its keywords to the keywords +hash table. You don't want to use this directly. See DEFRULE macro +instead." + (when (find-rule name *rules*) + (error "redefining rule ~A" name)) + (multiple-value-bind (rule keywords) + (create-rule name productions) + (add-rule name rule *rules*) + (dolist (term keywords) + (add-keyword term *keywords*)) + rule)) + +(defun resolve-nonterminals (tokens rules) + "Given a list of production tokens, try to expand the nonterminal +ones with their respective rule from the the RULES pool." + (flet ((resolve-symbol (sym) + (or (find-rule sym rules) + sym))) + (mapcar #'(lambda (tok) + (if (symbolp tok) + (resolve-symbol tok) + tok)) + tokens))) + +(defun reset-grammar () + "Empty the current grammar from any existing rule." + (setf *rules* (make-rules-table) + *keywords* (make-keywords-table))) + +(defun generate-grammar (&optional (equal-p #'string-equal)) + "Return a GRAMMAR structure suitable for the PARSE function, using +the current rules. EQUAL-P, if present, is a function to be used to +match the input tokens; it defaults to STRING-EQUAL." + (resolve-all-nonterminals *rules*) + (remove-left-recursivity-from-rules *rules*) + (make-grammar :rules *rules* + :keywords *keywords* + :equal-p equal-p)) diff --git a/third_party/lisp/npg/src/package.lisp b/third_party/lisp/npg/src/package.lisp new file mode 100644 index 000000000000..b405f7b5f19e --- /dev/null +++ b/third_party/lisp/npg/src/package.lisp @@ -0,0 +1,50 @@ +;;; package.lisp --- backtracking parser package definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :naive-parser-generator + (:nicknames :npg) + (:use :common-lisp) + (:export + #:parse ; The Parser + #:reset-grammar + #:generate-grammar + #:print-grammar-figures + #:grammar-keyword-p + #:keyword + #:grammar + #:make-token + #:token-value + #:token-type + #:token-position + #:later-position + #:defrule ; to define grammars + #:deftoken ; to define a lexer + #:input-cursor-mixin + #:copy-input-cursor-slots + #:dup-input-cursor + #:read-next-tokens + #:end-of-input + #:? #:+ #:* #:or + #:$vars #:$all #:$alist + #:$1 #:$2 #:$3 #:$4 #:$5 #:$6 #:$7 #:$8 #:$9 #:$10)) diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp new file mode 100644 index 000000000000..328be1dcf30f --- /dev/null +++ b/third_party/lisp/npg/src/parser.lisp @@ -0,0 +1,234 @@ +;;; parser.lisp --- runtime parser + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: parser.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is the runtime part of the parser. The code that is +;;; responsible to execute the parser defined with the primitives +;;; found in define.lisp. + +(in-package :naive-parser-generator) + +(defvar *debug* nil + "Either nil or a stream where to write the debug informations.") +#+debug (declaim (fixnum *maximum-recursion-depth*)) +#+debug (defvar *maximum-recursion-depth* 1000 + "Maximum depth the parser is allowed to recursively call itself. +This is the only way for the parser to detect a loop in the grammar. +Tune this if your grammar is unusually complex.") + +(declaim (inline reduce-production)) +(defun reduce-production (production arguments) + "Apply PRODUCTION's action on ARGUMENTS. This has the effect of + \"reducing\" the production." + (when *debug* + (format *debug* "reducing ~S on ~S~%" production arguments)) + (flet ((safe-token-value (token) + (if (token-p token) + (token-value token) + token))) + (apply (prod-action production) (mapcar #'safe-token-value arguments)))) + +(defgeneric later-position (pos1 pos2) + (:documentation + "Compare two file postions and return true if POS1 is later than +POS2 in the input stream.")) + +;; This is meant to be overloaded in the lexer +(defmethod later-position ((pos1 integer) (pos2 integer)) + (> pos1 pos2)) + +;; this looks silly but turns out to be useful (see below) +(defmethod later-position (pos1 pos2) + (and (eq pos1 :eof) (not (eq pos2 :eof)))) + +(defgeneric read-next-tokens (tokens-source) + (:documentation "Read next token from a lexical analysed stream. The nature of +TOKENS-SOURCE is implementation dependent and any lexical analyzer is +supposed to specialise this method.")) + +;; This is the actual parser. the algorithm is pretty +;; straightforward, the execution of the reductions a bit less. Error +;; recovery is rather clumsy. + +(defun parse (grammar start tokenizer) + "Match a GRAMMAR against the list of input tokens coming from TOKENIZER. +Return the reduced values according to the nonterminal actions. Raise +an error on failure." + (declare (type grammar grammar) + (type symbol start)) + (labels + ((match-token (expected token) + (when *debug* + (format *debug* "match-token ~S ~S -> " expected token)) + (let ((res (cond ((symbolp expected) + ;; non-costant terminal (like identifiers) + (eq expected (token-type token))) + ((and (stringp expected) + (stringp (token-value token))) + ;; string costant terminal + (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) + ((functionp expected) + ;; custom equality predicate (must be able + ;; to deal with token objects) + (funcall expected token)) + ;; all the rest + (t (equal expected (token-value token)))))) + (when *debug* + (format *debug* "~Amatched~%" (if res "" "not "))) + res)) + (match (expected matched #+debug depth) + (declare (list expected matched) + #+debug (fixnum depth)) + (let ((first-expected (car expected))) + (cond #+debug ((> depth *maximum-recursion-depth*) + (error "endless recursion on ~A ~A at ~A expecting ~S" + (token-type (car matched)) (token-value (car matched)) + (token-position (car matched)) expected)) + ((eq first-expected :any) + (match (cdr expected) (cdr matched) #+debug depth)) + ;; This is a trick to obtain partial parses. When we + ;; reach this expected token we assume we succeeded + ;; the parsing and return the remaining tokens as + ;; part of the match. + ((eq first-expected :rest) + ;; we could be at the end of input so we check this + (unless (cdr matched) + (setf (cdr matched) (list :rest))) + (list nil nil)) + ((rule-p first-expected) + ;; If it's a rule, then we try to match all its + ;; productions. We return the first that succeeds. + (loop + for production in (rule-productions first-expected) + for production-tokens of-type list = (prod-tokens production) + with last-error-position = nil + with last-error = nil + for (error-position error-descr) = + (progn + (when *debug* + (format *debug* "trying to match ~A: ~S~%" + (rule-name first-expected) production-tokens)) + (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) + do (cond ((not error-position) + (return (let ((args-count (prod-tokens-length production))) + (setf (cdr matched) + (cons (reduce-production + production + (subseq (the list (cdr matched)) 0 args-count)) + (nthcdr (1+ args-count) matched))) + (list nil nil)))) + ((or (not last-error) + (later-position error-position last-error-position)) + (setf last-error-position error-position + last-error error-descr))) + ;; if everything fails return the "best" error + finally (return (list last-error-position + (if *debug* + #'(lambda () + (format nil "~A, trying to match ~A" + (funcall (the function last-error)) + (rule-name first-expected))) + last-error))))) + (t + ;; if necessary load the next tokens + (when (null (cdr matched)) + (setf (cdr matched) (read-next-tokens tokenizer))) + (cond ((and (or (null expected) (eq first-expected :eof)) + (null (cdr matched))) + ;; This point is reached only once for each complete + ;; parsing. The expected tokens and the input + ;; tokens have been exhausted at the same time. + ;; Hence we succeeded the parsing. + (setf (cdr matched) (list :eof)) + (list nil nil)) + ((null expected) + ;; Garbage at end of parsing. This may mean that we + ;; have considered a production completed too soon. + (list (token-position (car matched)) + #'(lambda () + "garbage at end of parsing"))) + ((null (cdr matched)) + ;; EOF error + (list :eof + #'(lambda () + (format nil "end of input expecting ~S" expected)))) + (t ;; normal token + (let ((first-token (cadr matched))) + (if (match-token first-expected first-token) + (match (cdr expected) (cdr matched) #+debug depth) + ;; failed: we return the error + (list (token-position first-token) + #'(lambda () + (format nil "expected ~S but got ~S ~S" + first-expected (token-type first-token) + (token-value first-token))))))))))))) + (declare (inline match-token)) + (let ((result (list :head))) + (destructuring-bind (error-position error) + (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) + (when error-position + (error "~A at ~A~%" (funcall (the function error)) error-position)) + (cadr result))))) + +(defgeneric terminals-in-grammar (grammar-or-hashtable) + (:documentation + "Find non constant terminal symbols in GRAMMAR.")) + +(defmethod terminals-in-grammar ((grammar hash-table)) + (loop + for rule being each hash-value of grammar + with terminals = '() + do (loop + for prod in (rule-productions rule) + do (loop + for tok in (prod-tokens prod) + when (symbolp tok) + do (pushnew tok terminals))) + finally (return terminals))) + +(defmethod terminals-in-grammar ((grammar grammar)) + (terminals-in-grammar (grammar-rules grammar))) + +(defun print-grammar-figures (grammar &optional (stream *standard-output*)) + (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%" + (hash-table-count (grammar-rules grammar)) + (hash-table-count (grammar-keywords grammar)) + (terminals-in-grammar (grammar-rules grammar)))) + + +(defun grammar-keyword-p (keyword grammar) + "Check if KEYWORD is part of this grammar." + (find-keyword keyword (grammar-keywords grammar))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *grammars* (make-hash-table)) + +(defun find-grammar (name) + (gethash name *grammars*)) + +(defun delete-grammar (name) + (remhash name *grammars*)) + +(defun add-grammar (name grammar) + (setf (gethash name *grammars*) grammar)) diff --git a/third_party/lisp/parse-float.nix b/third_party/lisp/parse-float.nix new file mode 100644 index 000000000000..4e36e69c7d98 --- /dev/null +++ b/third_party/lisp/parse-float.nix @@ -0,0 +1,22 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "soemraws"; + repo = "parse-float"; + rev = "3074765101e41222b6b624a66aaf1e6416379f9c"; + sha256 = "0jd2spawc3v8vzqf8ky4cngl45jm65fhkrdf20mf6dcbn3mzpkmr"; + }; + +in depot.nix.buildLisp.library { + name = "parse-float"; + + deps = with depot.third_party.lisp; [ + alexandria + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "parse-float.lisp" + ]; +} diff --git a/third_party/lisp/parse-number.nix b/third_party/lisp/parse-number.nix new file mode 100644 index 000000000000..1ceba2863d8d --- /dev/null +++ b/third_party/lisp/parse-number.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "sharplispers"; + repo = "parse-number"; + rev = "7707b224c4b941c2cbd28459113534242cee3a31"; + sha256 = "0sk06ib1bhqv9y39vwnnw44vmbc4b0kvqm37xxmkxd4dwchq82d7"; + }; + +in depot.nix.buildLisp.library { + name = "parse-number"; + srcs = map (f: src + ("/" + f)) [ + "parse-number.lisp" + ]; +} diff --git a/third_party/lisp/parseq.nix b/third_party/lisp/parseq.nix new file mode 100644 index 000000000000..fe045d52996f --- /dev/null +++ b/third_party/lisp/parseq.nix @@ -0,0 +1,20 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "mrossini-ethz"; + repo = "parseq"; + rev = "5cd95b324b68255d89f27f8065f4c29674558b26"; + sha256 = "1f3vvxgyiv0xn2hzafhh63l3gnvn2vaxr5pi3ld7d340mka2ndg0"; + }; + +in depot.nix.buildLisp.library { + name = "parseq"; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "conditions.lisp" + "utils.lisp" + "defrule.lisp" + ]; +} diff --git a/third_party/lisp/physical-quantities.nix b/third_party/lisp/physical-quantities.nix new file mode 100644 index 000000000000..b8079e8ebaaf --- /dev/null +++ b/third_party/lisp/physical-quantities.nix @@ -0,0 +1,31 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "mrossini-ethz"; + repo = "physical-quantities"; + rev = "v0.2.1"; + sha256 = "0mb2s94s6fhw5vfa89naalw7ld11sdsszlqpz0c65dvpfyfmmdmh"; + }; + +in depot.nix.buildLisp.library { + name = "physical-quantities"; + + deps = with depot.third_party.lisp; [ + parseq + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "utils.lisp" + "conditions.lisp" + "unit-factor.lisp" + "unit-database.lisp" + "units.lisp" + "quantity.lisp" + "numeric.lisp" + "parse-rules.lisp" + "read-macro.lisp" + "si-units.lisp" + ]; +} diff --git a/third_party/lisp/postmodern.nix b/third_party/lisp/postmodern.nix new file mode 100644 index 000000000000..333a9d9b770f --- /dev/null +++ b/third_party/lisp/postmodern.nix @@ -0,0 +1,94 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + + src = pkgs.fetchFromGitHub { + owner = "marijnh"; + repo = "Postmodern"; + rev = "v1.32"; + sha256 = "0prwmpixcqpzqd67v77cs4zgbs73a10m6hs7q0rpv0z1qm7mqfcb"; + }; + + cl-postgres = depot.nix.buildLisp.library { + name = "cl-postgres"; + deps = with depot.third_party.lisp; [ + md5 + split-sequence + ironclad + cl-base64 + uax-15 + usocket + ]; + + srcs = map (f: src + ("/cl-postgres/" + f)) [ + "package.lisp" + "features.lisp" + "errors.lisp" + "sql-string.lisp" + "trivial-utf-8.lisp" + "strings-utf-8.lisp" + "communicate.lisp" + "messages.lisp" + "oid.lisp" + "ieee-floats.lisp" + "interpret.lisp" + "saslprep.lisp" + "scram.lisp" + "protocol.lisp" + "public.lisp" + "bulk-copy.lisp" + ]; + }; + + s-sql = depot.nix.buildLisp.library { + name = "s-sql"; + deps = with depot.third_party.lisp; [ + cl-postgres + alexandria + ]; + + srcs = map (f: src + ("/s-sql/" + f)) [ + "package.lisp" + "s-sql.lisp" + ]; + }; + + postmodern = depot.nix.buildLisp.library { + name = "postmodern"; + + deps = with depot.third_party.lisp; [ + alexandria + cl-postgres + s-sql + global-vars + split-sequence + cl-unicode + closer-mop + bordeaux-threads + ]; + + srcs = [ + "${src}/postmodern.asd" + ] ++ (map (f: src + ("/postmodern/" + f)) [ + "package.lisp" + "connect.lisp" + "query.lisp" + "prepare.lisp" + "roles.lisp" + "util.lisp" + "transaction.lisp" + "namespace.lisp" + "execute-file.lisp" + "table.lisp" + "deftable.lisp" + ]); + + brokenOn = [ + "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651 + ]; + }; + +in postmodern // { + inherit s-sql cl-postgres; +} diff --git a/third_party/lisp/prove.nix b/third_party/lisp/prove.nix deleted file mode 100644 index 7c5879b1fded..000000000000 --- a/third_party/lisp/prove.nix +++ /dev/null @@ -1,31 +0,0 @@ -{ depot, briefcase, ... }: - -let - src = builtins.fetchGit { - url = "https://github.com/fukamachi/prove.git"; - rev = "5d71f02795b89e36f34e8c7d50e69b67ec6ca2de"; - }; -in depot.nix.buildLisp.library { - name = "prove"; - deps = [ - depot.third_party.lisp.cl-ppcre - depot.third_party.lisp.cl-ansi-text - depot.third_party.lisp.alexandria - depot.third_party.lisp.uiop - briefcase.third_party.lisp.cl-colors - ]; - srcs = [ - "${src}/src/asdf.lisp" - "${src}/src/suite.lisp" - "${src}/src/color.lisp" - "${src}/src/output.lisp" - "${src}/src/prove.lisp" - "${src}/src/report.lisp" - "${src}/src/reporter.lisp" - "${src}/src/test.lisp" - "${src}/src/reporter/dot.lisp" - "${src}/src/reporter/fiveam.lisp" - "${src}/src/reporter/list.lisp" - "${src}/src/reporter/tap.lisp" - ]; -} diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix new file mode 100644 index 000000000000..925b457f9f03 --- /dev/null +++ b/third_party/lisp/puri.nix @@ -0,0 +1,14 @@ +# Portable URI library +{ depot, pkgs, ... }: + +let src = pkgs.fetchgit { + url = "http://git.kpe.io/puri.git"; + rev = "4bbab89d9ccbb26346899d1f496c97604fec567b"; + sha256 = "0gq2rsr0aihs0z20v4zqvmdl4szq53b52rh97pvnmwrlbn4mapmd"; +}; +in depot.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 000000000000..2d590a0564ae --- /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/default.nix b/third_party/lisp/quasiquote_2/default.nix new file mode 100644 index 000000000000..521c384787fe --- /dev/null +++ b/third_party/lisp/quasiquote_2/default.nix @@ -0,0 +1,17 @@ +# Quasiquote more suitable for macros that define other macros +{ depot, ... }: + +depot.nix.buildLisp.library { + name = "quasiquote-2.0"; + + deps = [ + depot.third_party.lisp.iterate + ]; + + srcs = [ + ./package.lisp + ./quasiquote-2.0.lisp + ./macros.lisp + ./readers.lisp + ]; +} diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp new file mode 100644 index 000000000000..6ebeb47d081e --- /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 000000000000..9b140ef84c32 --- /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 000000000000..3acfd32b80e6 --- /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 000000000000..10043fe0ecbc --- /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) + +(defparameter *void-elt* nil) +(defparameter *void-filter-needed* 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))) + +(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 000000000000..7c4c5a30c98e --- /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 000000000000..df6c43e21d77 --- /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 000000000000..6c8ab08cc1af --- /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/restas.nix b/third_party/lisp/restas.nix new file mode 100644 index 000000000000..cf231286e79a --- /dev/null +++ b/third_party/lisp/restas.nix @@ -0,0 +1,41 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "archimag"; + repo = "restas"; + rev = "81bbbab6b36f81f846f78e71232e9d3d15f6d952"; + sha256 = "00ng6jik1lwjw3bbxhijy8s0ml24lgm73liwrr01gcsb0r6wrjjn"; + }; + +in depot.nix.buildLisp.library { + name = "restas"; + deps = with depot.third_party.lisp; [ + cffi + hunchentoot + bordeaux-threads + routes + alexandria + data-sift + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "packages.lisp" + "special.lisp" + "declarations.lisp" + "errors.lisp" + "render.lisp" + "context.lisp" + "module.lisp" + "route.lisp" + "decorators.lisp" + "vhost.lisp" + "hunchentoot.lisp" + "policy.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix new file mode 100644 index 000000000000..6af55f927001 --- /dev/null +++ b/third_party/lisp/rfc2388.nix @@ -0,0 +1,17 @@ +# Implementation of RFC2388 (multipart/form-data) +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "jdz"; + repo = "rfc2388"; + rev = "591bcf7e77f2c222c43953a80f8c297751dc0c4e"; + sha256 = "0phh5n3clhl9ji8jaxrajidn22d3f0aq87mlbfkkxlnx2pnw694k"; +}; +in depot.nix.buildLisp.library { + name = "rfc2388"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "rfc2388.lisp" + ]; +} diff --git a/third_party/lisp/routes.nix b/third_party/lisp/routes.nix new file mode 100644 index 000000000000..a76912c651a9 --- /dev/null +++ b/third_party/lisp/routes.nix @@ -0,0 +1,38 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.applyPatches { + name = "routes-source"; + src = pkgs.fetchFromGitHub { + owner = "archimag"; + repo = "cl-routes"; + rev = "1b79e85aa653e1ec87e21ca745abe51547866fa9"; + sha256 = "1zpk3cp2v8hm50ppjl10yxr437vv4552r8hylvizglzrq2ibsbr1"; + }; + + patches = [ + (pkgs.fetchpatch { + name = "fix-build-with-ccl.patch"; + url = "https://github.com/archimag/cl-routes/commit/2296cdc316ef8e34310f2718b5d35a30040deee0.patch"; + sha256 = "007c19kmymalam3v6l6y2qzch8xs3xnphrcclk1jrpggvigcmhax"; + }) + ]; + }; + +in depot.nix.buildLisp.library { + name = "routes"; + + deps = with depot.third_party.lisp; [ + puri + iterate + split-sequence + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "uri-template.lisp" + "route.lisp" + "mapper.lisp" + ]; +} diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix new file mode 100644 index 000000000000..571eb147c724 --- /dev/null +++ b/third_party/lisp/s-sysdeps.nix @@ -0,0 +1,17 @@ +# A Common Lisp abstraction layer over platform dependent functionality. +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "svenvc"; + repo = "s-sysdeps"; + rev = "d28246b5dffef9e73a0e0e6cfbc4e878006fe34d"; + sha256 = "14b69b81yrxmjlvmm3lfxk04x5v7hqz4fql121334wh72czznfh9"; +}; +in depot.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 000000000000..40caffa8e257 --- /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 000000000000..ac196619c0aa --- /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 000000000000..0c7292ea9fb5 --- /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 000000000000..82b6317f372c --- /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'. +{ depot, ... }: + +depot.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 000000000000..b26453e6ea66 --- /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 000000000000..a0befe2cbbbb --- /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 000000000000..41d858b4a8c5 --- /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 000000000000..c8a3eaec1f2b --- /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 000000000000..651f5e5844c2 --- /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 000000000000..74d1c371db22 --- /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 000000000000..d43df6cf8171 --- /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 000000000000..f90f0f49a166 --- /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 000000000000..c9e0f9e0db4e --- /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 000000000000..70373889152f --- /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 000000000000..8a2076985a49 --- /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 000000000000..91d78707b8a1 --- /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 000000000000..910e6326ea63 --- /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 000000000000..08ad9424e3ae --- /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 000000000000..248e1e4b907f --- /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 000000000000..7164d5ef0d66 --- /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 000000000000..f5ee1cc92583 --- /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 000000000000..daef58ea4639 --- /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 000000000000..79f3ae3bade6 --- /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/sclf/.skip-subtree b/third_party/lisp/sclf/.skip-subtree new file mode 100644 index 000000000000..5051f60d6b86 --- /dev/null +++ b/third_party/lisp/sclf/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/sclf/OWNERS b/third_party/lisp/sclf/OWNERS new file mode 100644 index 000000000000..f16dd105d761 --- /dev/null +++ b/third_party/lisp/sclf/OWNERS @@ -0,0 +1,3 @@ +inherited: true +owners: + - sterni diff --git a/third_party/lisp/sclf/README b/third_party/lisp/sclf/README new file mode 100644 index 000000000000..2a1c2c3c5c1c --- /dev/null +++ b/third_party/lisp/sclf/README @@ -0,0 +1,6 @@ +SCLF has originally been written by Walter C. Pelissero and vendored +into depot since it is a dependency of mime4cl. Upstream and depot version +may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#sclf +Vendored Tarball: http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz diff --git a/third_party/lisp/sclf/default.nix b/third_party/lisp/sclf/default.nix new file mode 100644 index 000000000000..fb07f8f764e5 --- /dev/null +++ b/third_party/lisp/sclf/default.nix @@ -0,0 +1,28 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "sclf"; + + deps = [ + (depot.nix.buildLisp.bundled "sb-posix") + ]; + + srcs = [ + ./package.lisp + ./sclf.lisp + ./sysproc.lisp + ./lazy.lisp + ./time.lisp + ./directory.lisp + ./serial.lisp + ./mp/sbcl.lisp + ]; + + # TODO(sterni): implement OS interaction for ECL and CCL + brokenOn = [ + "ecl" + "ccl" + ]; +} diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp new file mode 100644 index 000000000000..4684a8e7056a --- /dev/null +++ b/third_party/lisp/sclf/directory.lisp @@ -0,0 +1,404 @@ +;;; directory.lisp --- filesystem directory access + +;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: directory.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + + +(cl:in-package :sclf) + +(defun pathname-as-directory (pathname) + "Converts PATHNAME to directory form and return it." + (setf pathname (pathname pathname)) + (if (pathname-name pathname) + (make-pathname :directory (append (or (pathname-directory pathname) + '(:relative)) + (list (file-namestring pathname))) + :name nil + :type nil + :defaults pathname) + pathname)) + +(defun d+ (path &rest rest) + "Concatenate directory pathname parts and return a pathname." + (make-pathname :defaults path + :directory (append (pathname-directory path) rest))) + +(defun delete-directory (pathname) + "Remove directory PATHNAME. Return PATHNAME." + #+cmu (multiple-value-bind (done errno) + (unix:unix-rmdir (namestring pathname)) + (unless done + (error "Unable to delete directory ~A (errno=~A)" + pathname errno))) + #+sbcl (sb-posix:rmdir pathname) + #+lispworks (lw:delete-directory pathname) + #-(or cmu sbcl) + (error "DELETE-DIRECTORY not implemented for you lisp system.") + pathname) + +(defun list-directory (pathname &key truenamep) + "List content of directory PATHNAME. If TRUENAMEP is true don't try +to follow symbolic links." + #-(or sbcl cmu) (declare (ignore truenamep)) + (let (#+cmu (lisp::*ignore-wildcards* t)) + (directory (make-pathname :defaults (pathname-as-directory pathname) + :name :wild + :type :wild + :version :wild) + #+cmu :truenamep #+cmu truenamep + #+sbcl :resolve-symlinks #+sbcl truenamep))) + +(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first) + "Call PROC on all pathnames under ROOT-PATHNAME, both files and +directories. Unless TRUENAMEP is true, this function doesn't try +to lookup the truename of files, as finding the truename may be a +superfluous and noxious activity expecially when you expect +broken symbolic links in your filesystem." + (check-type root-pathname pathname) + (check-type proc (or function symbol)) + (check-type test (or function symbol null)) + (labels ((ls (dir) + (declare (type pathname dir)) + (list-directory dir :truenamep truenamep)) + (traverse? (file) + (declare (type pathname file)) + (and (not (pathname-name file)) + (or truenamep + (not (symbolic-link-p file))) + (or (not test) + (funcall test file)))) + (traverse-pre-order (dir) + (declare (type pathname dir)) + (loop + for file in (ls dir) + do (funcall proc file) + when (traverse? file) + do (traverse-pre-order file))) + (traverse-post-order (dir) + (declare (type pathname dir)) + (loop + for file in (ls dir) + when (traverse? file) + do (traverse-post-order file) + do (funcall proc file)))) + (if depth-first + (traverse-post-order root-pathname) + (traverse-pre-order root-pathname)) + (values))) + +(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body) + "Call TRAVERSE-DIRECTORY-TREE with BODY es procedure." + `(traverse-directory-tree ,root-pathname + #'(lambda (,file) + ,@body) + :truenamep ,truenamep + :test ,test + :depth-first ,depth-first)) + +(defun empty-directory-p (pathname) + (and (directory-p pathname) + (endp (list-directory pathname)))) + +(defun remove-empty-directories (root) + (do-directory-tree (pathname root :depth-first t) + (when (empty-directory-p pathname) + (delete-directory pathname)))) + +(defun map-directory-tree (pathname function) + "Apply FUNCTION to every file in a directory tree starting from +PATHNAME. Return the list of results." + (be return-list '() + (do-directory-tree (directory-entry pathname) + (push (funcall function directory-entry) return-list)) + (nreverse return-list))) + +(defun find-files (root-pathname matcher-function &key truenamep) + "In the directory tree rooted at ROOT-PATHNAME, find files that +when the pathname is applied to MATCHER-FUNCTION will return +true. Return the list of files found. Unless TRUENAMEP is true +this function doesn't try to lookup the truename of +files. Finding the truename may be a superfluous and noxious +activity expecially when you expect broken symbolic links in your +filesystem. (This may not apply to your particular lisp +system.)" + (be files '() + (do-directory-tree (file root-pathname :truenamep truenamep) + (when (funcall matcher-function file) + (push file files))) + (nreverse files))) + +(defun delete-directory-tree (pathname) + "Recursively delete PATHNAME and all the directory structure below +it. + +WARNING: depending on the way the DIRECTORY function is implemented on +your Lisp system this function may follow Unix symbolic links and thus +delete files outside the PATHNAME hierarchy. Check this before using +this function in your programs." + (if (pathname-name pathname) + (delete-file pathname) + (progn + (dolist (file (list-directory pathname)) + (delete-directory-tree file)) + (delete-directory pathname)))) + +(defun make-directory (pathname &optional (mode #o777)) + "Create a new directory in the filesystem. Permissions MODE +will be assigned to it. Return PATHNAME." + #+cmu (multiple-value-bind (done errno) + (unix:unix-mkdir (native-namestring pathname) mode) + (unless done + (error "Unable to create directory ~A (errno=~A)." pathname errno))) + #+sbcl (sb-posix:mkdir pathname mode) + #-(or cmu sbcl) + (error "MAKE-DIRECTORY is not implemented for this Lisp system.") + pathname) + +;; At least on SBCL/CMUCL + Unix + NFS this function is faster than +;; ENSURE-DIRECTORIES-EXIST, because it doesn't check all the pathname +;; components starting from the root; it proceeds from the leaf and +;; crawls the directory tree upward only if necessary." +(defun ensure-directory (pathname &key verbose (mode #o777)) + "Just like ENSURE-DIRECTORIES-EXIST but, in some situations, +it's faster." + (labels ((ensure (path) + (unless (probe-file path) + (be* tail (last (pathname-directory path) 2) + last (cdr tail) + (setf (cdr tail) nil) + (unwind-protect + (ensure path) + (setf (cdr tail) last)) + (make-directory path mode) + (when verbose + (format t "Created ~S~%" path)))))) + (ensure (make-pathname :defaults pathname + :name nil :type nil + :version nil)))) + +(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777)) + "Create a new directory and return its pathname. +If DEFAULT-PATHNAME is specified and not NIL it's used as +defaults to produce the pathname of the directory. Return the +pathname of the temporary directory." + (loop + for name = (pathname-as-directory (temp-file-name default-pathname)) + when (ignore-errors (make-directory name mode)) + return name)) + +(defmacro with-temp-directory ((path &rest make-temp-directory-args) &body body) + "Execute BODY with PATH bound to the pathname of a new unique +temporary directory. On exit of BODY the directory tree starting from +PATH will be automatically removed from the filesystem. Return what +BODY returns. BODY is _not_ executed within the PATH directory; the +working directory is never changed." + `(be ,path (make-temp-directory ,@make-temp-directory-args) + (unwind-protect + (progn ,@body) + (delete-directory-tree ,path)))) + +(defun current-directory () + "Return the pathname of the current directory." + (truename (make-pathname :directory '(:relative)))) + +(defun ensure-home-translations () + "Ensure that the logical pathname translations for the host \"home\" +are defined." + ;; CMUCL already defines a HOME translation of its own and gets + ;; angry if we try to redefine it + #-cmu + (be home (user-homedir-pathname) + ;; we should discard and replace whatever has been defined in any + ;; rc file during compilation + (setf (logical-pathname-translations "home") + (list + (list "**;*.*.*" + (make-pathname :defaults home + :directory (append (pathname-directory home) + '(:wild-inferiors)) + :name :wild + :type :wild)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) + #+sbcl (sb-ext:parse-native-namestring string host defaults + :start start + :end end + :junk-allowed junk-allowed) + #-sbcl (let (#+cmu(lisp::*ignore-wildcards* t)) + (parse-namestring string host defaults + :start start + :end end + :junk-allowed junk-allowed))) + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +(defun native-file-namestring (pathname) + #+sbcl (sb-ext:native-namestring + (make-pathname :name (pathname-name pathname) + :type (pathname-type pathname))) + #+cmu (be lisp::*ignore-wildcards* t + (file-namestring pathname))) + +(defun native-pathname (thing) + #+sbcl (sb-ext:native-pathname thing) + #+cmu (be lisp::*ignore-wildcards* t + (pathname thing))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun bits-set-p (x bits) + (= (logand x bits) + bits)) + +(defun directory-p (pathname) + "Return true if PATHNAME names a directory on the filesystem." + #-clisp (awhen (unix-stat (native-namestring pathname)) + (bits-set-p (stat-mode it) + #+sbcl sb-posix:s-ifdir + #+cmu unix:s-ifdir)) + #+clisp (ext:probe-directory (pathname-as-directory pathname))) + +(defun regular-file-p (pathname) + "Return true if PATHNAME names a regular file on the filesystem." + #-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file") + (awhen (unix-stat (native-namestring pathname)) + (bits-set-p (stat-mode it) + #+sbcl sb-posix:s-ifreg + #+cmu unix:s-ifreg))) + +(defun file-readable-p (pathname) + #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok) + #+cmu (unix:unix-access (native-namestring pathname) unix:r_ok) + #-(or sbcl cmu) (error "don't know how to check whether a file might be readable")) + +(defun file-writable-p (pathname) + #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:w_ok) + #+cmu (unix:unix-access (native-namestring pathname) unix:w_ok) + #-(or sbcl cmu) (error "don't know how to check whether a file might be writable")) + +(defun file-executable-p (pathname) + #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:x_ok) + #+cmu (unix:unix-access (native-namestring pathname) unix:x_ok) + #-(or sbcl cmu) (error "don't know how to check whether a file might be executable")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (unix-file-stat (:conc-name stat-)) + device + inode + links + atime + mtime + ctime + size + blksize + blocks + uid + gid + mode) + +(defun unix-stat (pathname) + ;; this could be different depending on the unix systems + (multiple-value-bind (ok? device inode mode links uid gid rdev + size atime mtime ctime + blksize blocks) + (#+cmu unix:unix-lstat + #+sbcl sb-unix:unix-lstat + (if (stringp pathname) + pathname + (native-namestring pathname))) + (declare (ignore rdev)) + (when ok? + (make-unix-file-stat :device device + :inode inode + :links links + :atime atime + :mtime mtime + :ctime ctime + :size size + :blksize blksize + :blocks blocks + :uid uid + :gid gid + :mode mode)))) + +(defun stat-modification-time (stat) + "Return the modification time of the STAT structure as Lisp +Universal Time, which is not the same as the Unix time." + (unix->universal-time (stat-mtime stat))) + +(defun stat-creation-time (stat) + "Return the creation time of the STAT structure as Lisp +Universal Time, which is not the same as the Unix time." + (unix->universal-time (stat-ctime stat))) + +(defun file-modification-time (file) + "Return the modification time of FILE as Lisp Universal Time, which +is not the same as the Unix time." + (awhen (unix-stat file) + (stat-modification-time it))) + +(defun file-creation-time (file) + "Return the creation time of FILE as Lisp Universal Time, which +is not the same as the Unix time." + (awhen (unix-stat file) + (stat-creation-time it))) + +(defun read-symbolic-link (symlink) + "Return the pathname the SYMLINK points to. That is, it's +contents." + #+sbcl (sb-posix:readlink (native-namestring symlink)) + #+cmu (unix:unix-readlink (native-namestring symlink))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + (stat-size (unix-stat pathname))) + +(defun symbolic-link-p (pathname) + #-(or sbcl cmu) (error "don't know hot to test for symbolic links.") + (aand (unix-stat pathname) + (bits-set-p (stat-mode it) + #+sbcl sb-posix:s-iflnk + #+cmu unix:s-iflnk))) + +(defun broken-link-p (pathname) + (when (symbolic-link-p pathname) + #+cmu (not (ignore-errors (truename pathname))) + ;; On a broken symlink SBCL returns the link path without resolving + ;; the link itself. De gustibus non est disputandum. + #+sbcl (equalp pathname (probe-file pathname)))) + +(defun move-file (old new) + "Just like RENAME-FILE, but doesn't carry on to NEW file the type of +OLD file, if NEW doesn't specify one. It does what most people would +expect from a rename function, which RENAME-FILE doesn't do. +So (MOVE-FILE \"foo.bar\" \"foo\") does rename foo.bar to foo, losing +the \"bar\" type; RENAME-FILE wouldn't allow you that." + #+sbcl (sb-posix:rename (native-namestring old) (native-namestring new)) + #+cmu (unix:unix-rename (native-namestring old) (native-namestring new))) diff --git a/third_party/lisp/sclf/lazy.lisp b/third_party/lisp/sclf/lazy.lisp new file mode 100644 index 000000000000..18f6bfdb7109 --- /dev/null +++ b/third_party/lisp/sclf/lazy.lisp @@ -0,0 +1,134 @@ +;;; lazy.lisp --- lazy primitives + +;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: lazy.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Lazy primitives +;;; + +(in-package :sclf) + +(defstruct promise + procedure + value) + +(defmacro lazy (form) + `(make-promise :procedure #'(lambda () ,form))) + +(defun forced-p (promise) + (null (promise-procedure promise))) + +(defun force (promise) + (if (forced-p promise) + (promise-value promise) + (prog1 (setf (promise-value promise) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) + +(defmacro deflazy (name value &optional documentation) + `(defparameter ,name (lazy ,value) + ,@(when documentation + (list documentation)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass lazy-metaclass (standard-class) + () + (:documentation "Metaclass for object having lazy slots. Lazy slots +should be specified with the :LAZY keyword which must be a function of +one argument. If required this function will be called once to get +the value to memoize in the slot. Lazy slots can also be set/read as +any other.")) + +(defmethod validate-superclass ((class lazy-metaclass) (super standard-class)) + "Lazy classes may inherit from ordinary classes." + (declare (ignore class super)) + t) + +(defmethod validate-superclass ((class standard-class) (super lazy-metaclass)) + "Ordinary classes may inherit from lazy classes." + (declare (ignore class super)) + t) + +(defclass lazy-slot-mixin () + ((lazy-function :initarg :lazy + :reader lazy-slot-function + :initform nil)) + (:documentation + "Slot for LAZY-METACLASS classes. Lazy slots must be declared with +the argument :LAZY which must be a function accepting the object +instance as argument.")) + +(defclass lazy-direct-slot-definition (lazy-slot-mixin standard-direct-slot-definition) + ()) + +(defclass lazy-effective-slot-definition (lazy-slot-mixin standard-effective-slot-definition) + ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod direct-slot-definition-class ((class lazy-metaclass) &rest initargs) + (if (getf initargs :lazy nil) + (find-class 'lazy-direct-slot-definition) + (call-next-method))) + +(defmethod effective-slot-definition-class ((class lazy-metaclass) &rest initargs) + (if (getf initargs :lazy nil) + (find-class 'lazy-effective-slot-definition) + (call-next-method))) + +(defmethod compute-effective-slot-definition-initargs ((class lazy-metaclass) direct-slots) + (let ((ds (car direct-slots))) + (if (typep ds 'lazy-direct-slot-definition) + (let ((form (lazy-slot-function ds)) + (args (call-next-method))) + (when (or (getf args :initarg) + (getf args :initform)) + (error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds)) + (list* :lazy + (cond ((and (listp form) + (eq 'lambda (car form))) + (compile nil form)) + ((symbolp form) + form) + (t (compile nil `(lambda (self) + (declare (ignorable self)) + ,form)))) + args)) + (call-next-method)))) + +(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin)) + (declare (ignore class)) + ;; If the slot is unbound, call the lazy function passing the + ;; instance and memoize the value in the slot. + (unless (slot-boundp-using-class class instance slot) + (setf (slot-value-using-class class instance slot) + (funcall (lazy-slot-function slot) instance))) + (call-next-method)) + +(defun reset-lazy-slots (object) + "Unbind all the lazy slots in OBJECT so that they will be +re-evaluated next time their value is requested again." + (be* class (class-of object) + (dolist (slot (class-slots class)) + (when (typep slot 'lazy-effective-slot-definition) + (slot-makunbound object (slot-definition-name slot)))))) \ No newline at end of file diff --git a/third_party/lisp/sclf/mp/README b/third_party/lisp/sclf/mp/README new file mode 100644 index 000000000000..a0732c029453 --- /dev/null +++ b/third_party/lisp/sclf/mp/README @@ -0,0 +1,6 @@ +This directory contains an uniforming layer for multiprocessing in the +style supported by Allegro Common Lisp and CMUCL. Almost nothing of +this has been written by me. It's mostly the work of Gilbert Baumann +(unk6@rz.uni-karlsruhe.de) and I've shamelessly lifted it from McCLIM. +The copyright disclaimer in this code is compatible with the one of +SCLF, so I believe there should be no legal issues. diff --git a/third_party/lisp/sclf/mp/cmu.lisp b/third_party/lisp/sclf/mp/cmu.lisp new file mode 100644 index 000000000000..6617f6dadd5d --- /dev/null +++ b/third_party/lisp/sclf/mp/cmu.lisp @@ -0,0 +1,115 @@ +;;; +;;; Code freely lifted from various places with compatible license +;;; terms. Most of this code is copyright Gilbert Baumann +;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter +;;; C. Pelissero <walter@pelissero.de>. +;;; + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +(in-package :sclf) + +(defun make-lock (&optional name) + (mp:make-lock name)) + +(defun make-recursive-lock (&optional name) + (mp:make-lock name :kind :recursive)) + +(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms) + `(mp:with-lock-held (,lock ,(or whostate "Lock Wait") + :wait wait + ,@(when timeout (list :timeout timeout))) + ,@forms)) + +(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms) + `(mp:with-lock-held (,lock + ,@(when wait (list :wait wait)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) + +(defstruct condition-variable + (lock (make-lock "condition variable")) + (value nil) + (process-queue nil)) + +(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp + #+i486 (kernel:%instance-set-conditional + lock 2 mp:*current-process* nil) + #-i486 (when (eq (lock-process lock) mp:*current-process*) + (setf (lock-process lock) nil))) + +(defun condition-wait (cv lock &optional timeout) + (declare (ignore timeout)) ;For now + (loop + (let ((cv-lock (condition-variable-lock cv))) + (with-lock-held (cv-lock) + (when (condition-variable-value cv) + (setf (condition-variable-value cv) nil) + (return-from condition-wait t)) + (setf (condition-variable-process-queue cv) + (nconc (condition-variable-process-queue cv) + (list mp:*current-process*))) + (%release-lock lock)) + (mp:process-add-arrest-reason mp:*current-process* cv) + (let ((cv-val nil)) + (with-lock-held (cv-lock) + (setq cv-val (condition-variable-value cv)) + (when cv-val + (setf (condition-variable-value cv) nil))) + (when cv-val + (mp::lock-wait lock "waiting for condition variable lock") + (return-from condition-wait t)))))) + +(defun condition-notify (cv) + (with-lock-held ((condition-variable-lock cv)) + (let ((proc (pop (condition-variable-process-queue cv)))) + ;; The waiting process may have released the CV lock but not + ;; suspended itself yet + (when proc + (loop + for activep = (mp:process-active-p proc) + while activep + do (mp:process-yield)) + (setf (condition-variable-value cv) t) + (mp:process-revoke-arrest-reason proc cv)))) + ;; Give the other process a chance + (mp:process-yield)) + +(defun process-execute (process function) + (mp:process-preset process function) + ;; For some obscure reason process-preset doesn't make the process + ;; runnable. I'm sure it's me who didn't understand how + ;; multiprocessing works under CMUCL, despite the vast documentation + ;; available. + (mp:enable-process process) + (mp:process-add-run-reason process :enable)) + +(defun destroy-process (process) + ;; silnetly ignore a process that is trying to destroy itself + (unless (eq (mp:current-process) + process) + (mp:destroy-process process))) + +(defun restart-process (process) + (mp:restart-process process) + (mp:enable-process process) + (mp:process-add-run-reason process :enable)) + +(defun process-alive-p (process) + (mp:process-alive-p process)) + +(defun process-join (process) + (error "PROCESS-JOIN not support under CMUCL.")) diff --git a/third_party/lisp/sclf/mp/sbcl.lisp b/third_party/lisp/sclf/mp/sbcl.lisp new file mode 100644 index 000000000000..7f47ec9c615f --- /dev/null +++ b/third_party/lisp/sclf/mp/sbcl.lisp @@ -0,0 +1,235 @@ +;;; +;;; Code freely lifted from various places with compatible license +;;; terms. Most of this code is copyright Daniel Barlow +;;; <dan@metacircles.com> or Gilbert Baumann +;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter +;;; C. Pelissero <walter@pelissero.de>. +;;; + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +(in-package :sclf) + +(defstruct (process + (:constructor %make-process) + (:predicate processp)) + name + state + whostate + function + thread) + +(defvar *current-process* + (%make-process + :name "initial process" :function nil + :thread + #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) + sb-thread:*current-thread* + #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) + (sb-thread:current-thread-id))) + +(defvar *all-processes* (list *current-process*)) + +(defvar *all-processes-lock* + (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) + +;; we implement disable-process by making the disablee attempt to lock +;; *permanent-queue*, which is already locked because we locked it +;; here. enable-process just interrupts the lock attempt. + +(defmacro get-mutex (mutex &optional (wait t)) + `( + #+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) + sb-thread:grab-mutex + #-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) + sb-thread:get-mutex + ,mutex :waitp ,wait)) + +(defvar *permanent-queue* + (sb-thread:make-mutex :name "Lock for disabled threads")) +(unless (sb-thread:mutex-owner *permanent-queue*) + (get-mutex *permanent-queue* nil)) + +(defun make-process (function &key name) + (let ((p (%make-process :name name + :function function))) + (sb-thread:with-mutex (*all-processes-lock*) + (pushnew p *all-processes*)) + (restart-process p))) + +(defun process-kill-thread (process) + (let ((thread (process-thread process))) + (when (and thread + (sb-thread:thread-alive-p thread)) + (assert (not (eq thread sb-thread:*current-thread*))) + (sb-thread:terminate-thread thread) + ;; Wait until all the clean-up forms are done. + (sb-thread:join-thread thread :default nil)) + (setf (process-thread process) nil))) + +(defun process-join (process) + (sb-thread:join-thread (process-thread process))) + +(defun restart-process (p) + (labels ((boing () + (let ((*current-process* p) + (function (process-function p))) + (when function + (funcall function))))) + (process-kill-thread p) + (when (setf (process-thread p) + (sb-thread:make-thread #'boing :name (process-name p))) + p))) + +(defun destroy-process (process) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*))) + (process-kill-thread process)) + +(defun current-process () + *current-process*) + +(defun all-processes () + ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value + ;; while that delete is executing, we could end up with nonsense. + ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS). + (sb-thread:with-mutex (*all-processes-lock*) + *all-processes*)) + +(defun process-yield () + (sb-thread:thread-yield)) + +(defun process-wait (reason predicate) + (let ((old-state (process-whostate *current-process*))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (until (funcall predicate) + (process-yield))) + (setf (process-whostate *current-process*) old-state)))) + +(defun process-wait-with-timeout (reason timeout predicate) + (let ((old-state (process-whostate *current-process*)) + (end-time (+ (get-universal-time) timeout))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + for result = (funcall predicate) + until (or result + (> (get-universal-time) end-time)) + do (process-yield) + finally (return result))) + (setf (process-whostate *current-process*) old-state)))) + +(defun process-interrupt (process function) + (sb-thread:interrupt-thread (process-thread process) function)) + +(defun disable-process (process) + (sb-thread:interrupt-thread + (process-thread process) + (lambda () + (catch 'interrupted-wait (get-mutex *permanent-queue*))))) + +(defun enable-process (process) + (sb-thread:interrupt-thread + (process-thread process) (lambda () (throw 'interrupted-wait nil)))) + +(defmacro without-scheduling (&body body) + (declare (ignore body)) + (error "WITHOUT-SCHEDULING is not supported on this platform.")) + +(defparameter *atomic-lock* + (sb-thread:make-mutex :name "atomic incf/decf")) + +(defmacro atomic-incf (place) + `(sb-thread:with-mutex (*atomic-lock*) + (incf ,place))) + +(defmacro atomic-decf (place) + `(sb-thread:with-mutex (*atomic-lock*) + (decf ,place))) + +;;; 32.3 Locks + +(defun make-lock (&optional name) + (sb-thread:make-mutex :name name)) + +(defmacro with-lock-held ((place &key state (wait t) timeout) &body body) + (declare (ignore timeout)) + (let ((old-state (gensym "OLD-STATE"))) + `(sb-thread:with-mutex (,place :wait-p ,wait) + (let (,old-state) + (unwind-protect + (progn + (when ,state + (setf ,old-state (process-state *current-process*)) + (setf (process-state *current-process*) ,state)) + ,@body) + (setf (process-state *current-process*) ,old-state)))))) + + +(defun make-recursive-lock (&optional name) + (sb-thread:make-mutex :name name)) + +(defmacro with-recursive-lock-held ((place &optional state (wait t) timeout) &body body) + (declare (ignore wait timeout)) + (let ((old-state (gensym "OLD-STATE"))) + `(sb-thread:with-recursive-lock (,place) + (let (,old-state) + (unwind-protect + (progn + (when ,state + (setf ,old-state (process-state *current-process*)) + (setf (process-state *current-process*) ,state)) + ,@body) + (setf (process-state *current-process*) ,old-state)))))) + +(defun make-condition-variable () (sb-thread:make-waitqueue)) + +(defun condition-wait (cv lock &optional timeout) + (if timeout + (handler-case + (sb-ext:with-timeout timeout + (sb-thread:condition-wait cv lock) + t) + (sb-ext:timeout (c) + (declare (ignore c)) + nil)) + (progn (sb-thread:condition-wait cv lock) t))) + +(defun condition-notify (cv) + (sb-thread:condition-notify cv)) + + +(defvar *process-plists* (make-hash-table) + "Hash table mapping processes to a property list. This is used by +PROCESS-PLIST.") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (value process) + (setf (gethash process *process-plists*) value)) + +(defun process-execute (process function) + (setf (process-function process) function) + (restart-process process)) + +(defun process-alive-p (process) + (sb-thread:thread-alive-p (process-thread process))) diff --git a/third_party/lisp/sclf/package.lisp b/third_party/lisp/sclf/package.lisp new file mode 100644 index 000000000000..652194f93cad --- /dev/null +++ b/third_party/lisp/sclf/package.lisp @@ -0,0 +1,258 @@ +;;; package.lisp --- packages description + +;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :sclf + (:use :common-lisp + ;; we need the MOP for lazy.lisp and serial.lisp + #+cmu :pcl + #+sbcl :sb-mop) + ;; Don't know why but compute-effective-slot-definition-initargs is + ;; internal in both CMUCL and SBCL + (:import-from #+cmu"PCL" #+sbcl"SB-PCL" + #-(or cmu sbcl) "CLOS" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS") + #+cmu (:import-from :mp + #:make-process + #:current-process + #:all-processes + #:processp + #:process-name + #:process-state + #:process-whostate + #:process-wait + #:process-wait-with-timeout + #:process-yield + #:process-interrupt + #:disable-process + #:enable-process + #:without-scheduling + #:atomic-incf + #:atomic-decf + #:process-property-list) + (:export #:be #:be* + #:defconst + #:with-gensyms + #:d+ + #:s+ + #:f++ + #:list->string + #:string-starts-with #:string-ends-with + #:aif #:awhen #:acond #:aand #:acase #:it + #:+whitespace+ + #:string-trim-whitespace + #:string-right-trim-whitespace + #:string-left-trim-whitespace + #:whitespace-p #:seq-whitespace-p + #:not-empty + #:position-any + #:+month-names+ + #:find-any + #:split-at + #:split-string-at-char + #:week-day->string + #:month->string + #:month-string->number + #:add-months #:add-days + #:read-whole-stream + #:read-file #:write-file #:read-lines + #:read-from-file #:write-to-file + #:string-concat + #:gcase + #:string-truncate + #:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots + #:copy-stream #:copy-file + #:symlink-file + #:keywordify + #:until + #:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year + #:beginning-of-week #:end-of-week + #:next-week-day #:next-monday #:full-weeks-in-span + #:beginning-of-first-week #:end-of-last-week + #:beginning-of-month #:end-of-month + #:locate-system-program + #:*tmp-file-defaults* + #:temp-file-name + #:open-temp-file + #:with-temp-file + #:file-size + #:getenv + #:with-system-environment + #:time-string #:iso-time-string #:parse-iso-time-string + #:soundex + #:string-soundex= + #:lru-cache + #:getcache #:cached + #:print-time-span + #:double-linked-list #:limited-list #:sorted-list + #:insert #:size + #:heap #:heap-add #:heap-pop #:heap-empty-p + #:double-linked-element #:make-double-linked-element #:double-linked-element-p + #:dle-previous #:dle-next #:dle-value + #:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle* + #:sl-map #:do-dll #:do-dll* + #:dll-find #:dll-find-cursor + #:push-first #:push-last #:dll-remove + #:pop-first #:pop-last + #:leap-year-p #:last-day-of-month + #:getuid #:setuid #:with-euid + #:get-logname #:get-user-name #:get-user-home #:find-uid + #:super-user-p + #:pathname-as-directory #:pathname-as-file + #:alist->plist #:plist->alist + #:byte-vector->string + #:string->byte-vector + #:outdated-p + #:with-hidden-temp-file + #:let-places #:let-slots + #:*decimal-point* + #:*thousands-comma* + #:format-amount #:parse-amount + #:with-package + #:make-directory #:ensure-directory + #:make-temp-directory + #:with-temp-directory + #:delete-directory + #:delete-directory-tree + #:do-directory-tree + #:traverse-directory-tree + #:empty-directory-p + #:remove-empty-directories + #:map-directory-tree + #:find-files + #:directory-p + #:regular-file-p + #:file-readable-p + #:file-writable-p + #:file-executable-p + #:current-directory + #:ensure-home-translations + #:list-directory + #:string-escape + #:string-substitute + #:bytes-simple-string + #:make-lock-files + #:with-lock-files + #:getpid + #:on-error + #:floor-to + #:round-to + #:ceiling-to + #:insert-in-order + #:forget-documentation + #:load-compiled + #:swap + #:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p + #:unix-stat #:unix-file-stat + #:stat-device + #:stat-inode + #:stat-links + #:stat-atime + #:stat-mtime + #:stat-ctime + #:stat-birthtime + #:stat-size + #:stat-blksize + #:stat-blocks + #:stat-uid + #:stat-gid + #:stat-mode + #:save-file-excursion + #:stat-modification-time + #:stat-creation-time + #:file-modification-time + #:file-creation-time + #:show + #:memoize-function + #:memoized + #:defun-memoized + #:parse-native-namestring + #:native-file-namestring + #:native-namestring + #:native-pathname + #:read-symbolic-link + #:symbolic-link-p + #:broken-link-p + #:circular-list + #:last-member + #:glob->regex + #:universal->unix-time #:unix->universal-time + #:get-unix-time + #:move-file + + ;; sysproc.lisp + #:*run-verbose* + #:run-pipe + #:run-program + #:run-shell-command + #:run-async-shell-command + #:exit-code + #:with-open-pipe + #:*bourne-shell* + #:sysproc-kill + #:sysproc-input + #:sysproc-output + #:sysproc-alive-p + #:sysproc-pid + #:sysproc-p + #:sysproc-wait + #:sysproc-exit-code + #:sysproc-set-signal-callback + + ;; MP + #:make-process + #:destroy-process + #:current-process + #:all-processes + #:processp + #:process-name + #:process-state + #:process-whostate + #:process-wait + #:process-wait-with-timeout + #:process-yield + #:process-interrupt + #:disable-process + #:enable-process + #:restart-process + #:without-scheduling + #:atomic-incf + #:atomic-decf + #:process-property-list + #:process-alive-p + #:process-join + ;; + #:make-lock + #:with-lock-held + #:make-recursive-lock + #:with-recursive-lock-held + ;; + #:make-condition-variable + #:condition-wait + #:condition-notify + #:process-property-list + #:process-execute + ;; mop.lisp + #:printable-object-mixin + )) diff --git a/third_party/lisp/sclf/sclf.asd b/third_party/lisp/sclf/sclf.asd new file mode 100644 index 000000000000..dfb56a8ded0e --- /dev/null +++ b/third_party/lisp/sclf/sclf.asd @@ -0,0 +1,58 @@ +;;; sclf.asd --- system definition + +;;; Copyright (C) 2005, 2006, 2008, 2009 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: SCLF + +#+cmu (ext:file-comment "$Module: sclf.asd, Time-stamp: <2013-06-17 15:32:29 wcp> $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :sclf-system + (:use :common-lisp :asdf #+asdfa :asdfa)) + +(in-package :sclf-system) + +(defsystem sclf + :name "SCLF" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + ;; :version "0.0" + :description "Stray Common Lisp Functions" + :long-description + "A collection of Common Lisp functions for the most disparate +uses, too small to fit anywhere else." + :licence "LGPL" + :depends-on (#+sbcl :sb-posix) + :components + ((:doc-file "README") + (:file "package") + (:file "sclf" :depends-on ("package")) + (:file "sysproc" :depends-on ("package" "sclf")) + (:file "lazy" :depends-on ("package" "sclf")) + (:file "time" :depends-on ("package" "sclf")) + (:file "directory" :depends-on ("package" "sclf" "time")) + (:file "serial" :depends-on ("package" "sclf")) + (:module "mp" + :depends-on ("package" "sclf") + :components + ((:doc-file "README") + (:file #.(first + (list #+cmu "cmu" + #+sbcl "sbcl" + "unknown"))))))) diff --git a/third_party/lisp/sclf/sclf.lisp b/third_party/lisp/sclf/sclf.lisp new file mode 100644 index 000000000000..0d587da8eb69 --- /dev/null +++ b/third_party/lisp/sclf/sclf.lisp @@ -0,0 +1,1717 @@ +;;; sclf.lisp --- miscellanea + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: SCLF + +#+cmu (ext:file-comment "$Module: sclf.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: + +;;; This is a collection of Common Lisp functions of the most disparate +;;; uses and purposes. These functions are too small or too unrelated +;;; to each other to deserve an own module. +;;; +;;; If you want to indent properly the following macros you should add +;;; the following lines to your .emacs file: +;;; +;;; (defun cl-indent-be (path state indent-point sexp-column normal-indent) +;;; (let ((sexp-start (cadr state)) +;;; (i 0)) +;;; (save-excursion +;;; (goto-char sexp-start) +;;; (forward-char) +;;; (+ sexp-column +;;; (block indentation +;;; (condition-case nil +;;; (while (< (point) indent-point) +;;; (setq i (1+ i)) +;;; (when (and (= 0 (logand i 1)) +;;; (looking-at "[\t\n ]*\\s(")) +;;; (return-from indentation 2)) +;;; (forward-sexp)) +;;; (error nil)) +;;; (if (= 1 (logand i 1)) +;;; 6 4)))))) +;;; +;;; (put 'be 'common-lisp-indent-function 'cl-indent-be) +;;; (put 'be* 'common-lisp-indent-function 'cl-indent-be) +;;; (put 'awhen 'lisp-indent-function 1) +;;; (put 'gcase 'lisp-indent-function 1) +;;; (put 'acase 'lisp-indent-function 1) +;;; (put 'acond 'lisp-indent-function 1) +;;; (put 'until 'lisp-indent-function 1) + + + +(cl:in-package :sclf) + +(defmacro be (&rest bindings-and-body) + "Less-parenthetic let." + (let ((bindings + (loop + while (and (symbolp (car bindings-and-body)) + (cdr bindings-and-body)) + collect (list (pop bindings-and-body) + (pop bindings-and-body))))) + `(let ,bindings + ,@bindings-and-body))) + +(defmacro be* (&rest bindings-and-body) + "Less-parenthetic let*." + (let ((bindings + (loop + while (and (symbolp (car bindings-and-body)) + (cdr bindings-and-body)) + collect (list (pop bindings-and-body) + (pop bindings-and-body))))) + `(let* ,bindings + ,@bindings-and-body))) + +(defmacro defconst (name value &rest etc) + "For some reason SBCL, between usefulness and adherence to the ANSI +standard, has chosen the latter, thus rendering the DEFCONSTANT pretty +useless. This macro works around that problem." + #+sbcl (list* 'defvar name value etc) + #-sbcl (list* 'defconstant name value etc)) + +(defmacro with-gensyms ((&rest symbols) &body body) + "Gensym all SYMBOLS and make them available in BODY. +See also LET-GENSYMS." + `(let ,(mapcar #'(lambda (s) + (list s '(gensym))) symbols) + ,@body)) + +(defun s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (be prefix-length (length prefix) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +(defun string-ends-with (postfix string &optional (compare #'string=)) + "Return true if STRING's last characters are the same as POSTFIX." + (be postfix-length (length postfix) + string-length (length string) + (and (>= string-length postfix-length) + (funcall compare postfix string :start2 (- string-length postfix-length))))) + +(defun string-substitute (from to sequence &key (start 0) end (test #'eql)) + "Replace in SEQUENCE occurrences of FROM with TO. FROM and TO don't +need to be the same length." + (be from-length (length from) + (with-output-to-string (out) + (write-string sequence out :start 0 :end start) + (loop + for position = (search from sequence :start2 start :end2 end :test test) + while position + do + (write-string sequence out :start start :end position) + (write-string to out) + (setf start (+ position from-length)) + finally (write-string (subseq sequence start) out))))) + +(defun string-escape (string character &key (escape-character #\\) (escape-escape t)) + "Prepend all occurences of CHARACTER in STRING with a +ESCAPE-CHARACTER." + (with-output-to-string (stream) + (loop + for c across string + when (or (char= c character) + (and escape-escape + (char= c escape-character))) + do (write-char escape-character stream) + do (write-char c stream)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro aif (test then &optional else) + `(be it ,test + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(be it ,test + (when it + ,@then))) + +(defmacro acond (&body forms) + (when forms + `(aif ,(caar forms) + (progn ,@(cdar forms)) + (acond ,@(cdr forms))))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro acase (condition &body forms) + `(be it ,condition + (case it ,@forms))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun string-trim-whitespace (string) + (string-trim +whitespace+ string)) + +(defun string-right-trim-whitespace (string) + (string-right-trim +whitespace+ string)) + +(defun string-left-trim-whitespace (string) + (string-left-trim +whitespace+ string)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(defun seq-whitespace-p (sequence) + (every #'whitespace-p sequence)) + +(defun not-empty (sequence) + "Return SEQUENCE if it's not empty, otherwise NIL. +NIL is indeed empty." + (when (or (listp sequence) + (not (zerop (length sequence)))) + sequence)) + +(defun position-any (bag sequence &rest position-args) + "Find any element of bag in sequence and return its position. +Accept any argument accepted by the POSITION function." + (apply #'position-if #'(lambda (element) + (find element bag)) sequence position-args)) + +(defun find-any (bag sequence &rest find-args) + "Find any element of bag in sequence. Accept any argument +accepted by the FIND function." + (apply #'find-if #'(lambda (element) + (find element bag)) sequence find-args)) + +(defun split-at (bag sequence &key (start 0) key) + "Split SEQUENCE at occurence of any element from BAG. +Contiguous occurences of elements from BAG are considered atomic; +so no empty sequence is returned." + (be len (length sequence) + (labels ((split-from (start) + (unless (>= start len) + (be sep (position-any bag sequence :start start :key key) + (cond ((not sep) + (list (subseq sequence start))) + ((> sep start) + (cons (subseq sequence start sep) + (split-from (1+ sep)))) + (t + (split-from (1+ start)))))))) + (split-from start)))) + +(defun split-string-at-char (string separator &key escape skip-empty) + "Split STRING at SEPARATORs and return a list of the substrings. If +SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is +not nil then split at SEPARATOR only if it's not preceded by ESCAPE." + (declare (type string string) (type character separator)) + (labels ((next-separator (beg) + (be pos (position separator string :start beg) + (if (and escape + pos + (plusp pos) + (char= escape (char string (1- pos)))) + (next-separator (1+ pos)) + pos))) + (parse (beg) + (cond ((< beg (length string)) + (let* ((end (next-separator beg)) + (substring (subseq string beg end))) + (cond ((and skip-empty (string= "" substring)) + (parse (1+ end))) + ((not end) + (list substring)) + (t + (cons substring (parse (1+ end))))))) + (skip-empty + '()) + (t + (list ""))))) + (parse 0))) + +(defun copy-stream (in out) + (loop + for c = (read-char in nil) + while c + do (write-char c out))) + +(defun pathname-as-file (pathname) + "Converts PATHNAME to file form and return it." + (unless (pathnamep pathname) + (setf pathname (pathname pathname))) + (cond ((pathname-name pathname) + pathname) + ((stringp (car (last (pathname-directory pathname)))) + (be name (parse-native-namestring (car (last (pathname-directory pathname)))) + (make-pathname :directory (butlast (pathname-directory pathname)) + :name (pathname-name name) + :type (pathname-type name) + :defaults pathname))) + ;; it can't be done? + (t pathname))) + +(defun copy-file (file copy-file &key (if-exists :error)) + (with-open-file (in file) + (with-open-file (out copy-file :direction :output :if-exists if-exists) + (copy-stream in out)))) + +(defun symlink-file (src dst &key (if-exists :error)) + (when (and (eq :supersede if-exists) + (probe-file dst)) + (delete-file dst)) + #+sbcl (sb-posix:symlink src dst) + #+cmu(unix:unix-symlink (native-namestring src) (native-namestring dst)) + #-(or sbcl cmu) (error "don't know how to symlink files")) + +(defun read-whole-stream (stream) + "Read stream until the end and return it as a string." + (with-output-to-string (string) + (loop + for line = (read-line stream nil) + while line + do (write-line line string)))) + +(defun read-lines (stream &optional n) + "Read N lines from stream and return them as a list of strings. If +N is NIL, read the whole stream til the end. If the stream ends +before N lines a read, this function will return those without +signalling an error." + (loop + for line = (read-line stream nil) + for i from 0 + while (and line + (or (not n) + (< i n))) + collect line)) + +(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (in pathname + :element-type element-type + :if-does-not-exist (unless (eq :value if-does-not-exist) + :error)) + (if in + (be seq (make-array (file-length in) :element-type element-type) + (read-sequence seq in) + seq) + default))) + +(defun write-file (pathname contents &key (if-exists :error)) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (out pathname + :element-type (if (stringp contents) + 'character + (array-element-type contents)) + :if-exists if-exists) + (write-sequence contents out))) + +(defun read-from-file (pathname &key (on-error :error) default) + "Similar to READ-FROM-STRING but for files. Read the first Lisp +object in file and return it. If file does not exist or does not +contain a readable Lisp object, ON-ERROR tells what to do. If +ON-ERROR is :ERROR, an error is signalled. If ON-ERROR is :VALUE, +DEFAULT is returned." + (ecase on-error + (:error + (with-open-file (in pathname) + (read in))) + (:value + (handler-case (with-open-file (in pathname) + (read in)) + (t () + default))))) + +(defun write-to-file (object pathname &key (if-exists :error) pretty) + "Similar to WRITE-TO-STRING but for files. Write OBJECT to a file +with pathname PATHNAME." + (with-open-file (out pathname :direction :output :if-exists if-exists) + (write object :stream out :escape t :readably t :pretty pretty))) + +(defun string-concat (list &optional (separator "")) + "Concatenate the strings in LIST interposing SEPARATOR (default +nothing) between them." + (reduce #'(lambda (&rest args) + (if args + (s+ (car args) separator (cadr args)) + "")) + list)) + +;; to indent it properly: (put 'gcase 'lisp-indent-function 1) +(defmacro gcase ((value &optional (test 'equalp)) &rest cases) + "Generic CASE macro. Match VALUE to CASES as if by the normal CASE +but use TEST as the comparison function, which defaults to EQUALP." + (with-gensyms (val) + `(be ,val ,value + ,(cons 'cond + (mapcar #'(lambda (case-desc) + (destructuring-bind (vals &rest forms) case-desc + `(,(cond ((consp vals) + (cons 'or (mapcar #'(lambda (v) + (list test val v)) + vals))) + ((or (eq vals 'otherwise) + (eq vals t)) + t) + (t (list test val vals))) + ,@forms))) + cases))))) + +(defun string-truncate (string max-length) + "If STRING is longer than MAX-LENGTH, return a shorter version. +Otherwise return the same string unchanged." + (if (> (length string) max-length) + (subseq string 0 max-length) + string)) + +;; to indent properly: (put 'until 'lisp-indent-function 1) +(defmacro until (test &body body) + (with-gensyms (result) + `(loop + for ,result = ,test + until ,result + do (progn ,@body) + finally (return ,result)))) + +(defun keywordify (string) + (intern (string-upcase string) :keyword)) + +(defun locate-system-program (name) + "Given the NAME of a system program try to find it through the +search of the environment variable PATH. Return the full +pathname." + (loop + for dir in (split-string-at-char (getenv "PATH") #\:) + for pathname = (merge-pathnames name (pathname-as-directory dir)) + when (probe-file pathname) + return pathname)) + +(defvar *tmp-file-defaults* #P"/tmp/") + +(defun temp-file-name (&optional (default *tmp-file-defaults*)) + "Create a random pathname based on DEFAULT. No effort is made +to make sure that the returned pathname doesn't identify an +already existing file. If missing DEFAULT defaults to +*TMP-FILE-DEFAULTS*." + (make-pathname :defaults default + :name (format nil "~36R" (random #.(expt 36 10))))) + +(defun open-temp-file (&optional default-pathname &rest open-args) + "Open a new temporary file and return a stream to it. This function +makes sure the pathname of the temporary file is unique. OPEN-ARGS +are arguments passed verbatim to OPEN. If OPEN-ARGS specify +the :DIRECTION it should be either :OUTPUT (default) or :IO; +any other value causes an error. If DEFAULT-PATHNAME is specified and +not NIL it's used as defaults to produce the pathname of the temporary +file, otherwise *TMP-FILE-DEFAULTS* is used." + (unless default-pathname + (setf default-pathname *tmp-file-defaults*)) + ;; if :DIRECTION is specified check that it's compatible with the + ;; purpose of this function, otherwise make it default to :OUTPUT + (aif (getf open-args :direction) + (unless (member it '(:output :io)) + (error "Can't create temporary file with open direction ~A." it)) + (setf open-args (append '(:direction :output) + open-args))) + (do* ((name #1=(temp-file-name default-pathname) #1#) + (stream #2=(apply #'open name + :if-exists nil + :if-does-not-exist :create + open-args) #2#)) + (stream stream))) + +(defmacro with-temp-file ((stream &rest open-temp-args) &body body) + "Execute BODY within a dynamic extent where STREAM is bound to +a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are +passed verbatim to OPEN-TEMP-FILE." + `(be ,stream (open-temp-file ,@open-temp-args) + (unwind-protect + (progn ,@body) + (close ,stream) + ;; body may decide to rename the file so we must ignore the errors + (ignore-errors + (delete-file (pathname ,stream)))))) + +(defmacro with-hidden-temp-file ((stream &rest open-args) &body body) + "Just like WITH-TEMP-FILE but unlink (delete) the temporary file +before the execution of BODY. As such BODY won't be able to +manipulate the file but through STREAM, and no other program is able +to see it. Once STREAM is closed the temporary file blocks are +automatically relinquished by the operating system. This works at +least on Unix filesystems. I don't know about MS-OSs where the system +may likely decide to crash, take all your data with it and, in the +meanwhile, report you to the NSA as terrorist." + `(be ,stream (open-temp-file ,@open-args) + (unwind-protect + (progn (delete-file (pathname ,stream)) + ,@body) + (close ,stream)))) + +(defun insert-in-order (item seq &key (test #'<) key) + "Destructively insert ITEM in LIST in order by TEST. Return +the new list. This is a simple wrapper around MERGE." + (merge (if seq + (type-of seq) + 'list) + (list item) seq test :key key)) + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +(defun soundex (word &optional (key-length 4)) + "Knuth's Soundex algorithm. Returns a string representing the +sound of a certain word (English). Different words will thus +yield the same output string. To compare two string by the +sound, simply do: + + (string= (soundex str1) (soundex str2)) + +Examples: + + (soundex \"Knuth\") => \"K530\" + (soundex \"Kant\") => \"K530\" + (soundex \"Lloyd\") => \"L300\" + (soundex \"Ladd\") => \"L300\"" + (declare (type string word)) + (flet ((translate-char (char) + (awhen (position char "BFPVCGJKQSXZDTLMNR") + (elt "111122222222334556" it)))) + (let ((key (make-string key-length :initial-element #\0)) + (word-length (length word))) + (setf (elt key 0) (elt word 0)) + (loop + with previous-sound = (translate-char (char-upcase (elt word 0))) + with j = 1 + for i from 1 by 1 below word-length + for c = (char-upcase (elt word i)) + while (< j key-length) + do (be sound (translate-char c) + (cond ((not (eq sound previous-sound)) + (unless (member c '(#\H #\W)) + (setf previous-sound sound)) + (when sound + (setf (elt key j) sound) + (incf j)))))) + key))) + +(defun string-soundex= (string1 string2) + (let ((l1 (split-at +whitespace+ string1)) + (l2 (split-at +whitespace+ string2))) + (and (= (length l1) (length l2)) + (every #'string= (mapcar #'soundex l1) (mapcar #'soundex l2))))) + +#+(OR) +(defun soundex-test () + (let* ((words1 '("Euler" "Gauss" "Hilbert" "Knuth" "Lloyd" "Lukasiewicz" "Wachs")) + (words2 '("Ellery" "Ghosh" "Heilbronn" "Kant" "Ladd" "Lissajous" "Waugh")) + (results '("E460" "G200" "H416" "K530" "L300" "L222" "W200"))) + (mapc #'(lambda (w1 w2 r) + (let ((r1 (soundex w1)) + (r2 (soundex w2))) + (format t "~A = ~A, ~A = ~A => ~A~%" w1 r1 w2 r2 + (if (and (string= r1 r2) + (string= r r1)) + "OK" + (format nil "ERROR (expected ~A)" r))))) + words1 words2 results) + (values))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defstruct cache-slot () +;; ((previous :type (or cache-slot null) +;; :initarg :previous +;; :initform nil +;; :accessor cslot-previous) +;; (key :initarg :key +;; :accessor cslot-key) +;; (value :initarg :value +;; :accessor cslot-value) +;; (next :type (or cache-slot null) +;; :initarg :next +;; :initform nil +;; :accessor cslot-next))) + +;; (defmethod print-object ((object cache-slot) stream) +;; (print-unreadable-object (object stream :type t) +;; (if (slot-boundp object 'key) +;; (format stream "key=~S, value=~S" (cslot-key object) (cslot-value object)) +;; (format stream "NULL")))) + + +(defstruct (double-linked-element (:conc-name dle-)) + (previous nil :type (or double-linked-element null)) + value + (next nil :type (or double-linked-element null))) + +(defmethod print-object ((object double-linked-element) stream) + (print-unreadable-object (object stream :type t) + (format stream "value=~S" (dle-value object)))) + +(defun cons-dle (value previous next) + (declare (type (or double-linked-element null) previous next)) + (be new-element (make-double-linked-element :previous previous :next next :value value) + (when previous + (setf (dle-next previous) new-element)) + (when next + (setf (dle-previous next) new-element)) + new-element)) + +(defun dle-remove (dle-object) + "Remove the DLE-OBJECT from its current position in the list of +elements agjusting the pointer of dle-objects before and after this +one (if any)." + (declare (type double-linked-element dle-object)) + (awhen (dle-next dle-object) + (setf (dle-previous it) (dle-previous dle-object))) + (awhen (dle-previous dle-object) + (setf (dle-next it) (dle-next dle-object)))) + +(defun dle-map (function dle-object) + (when dle-object + (make-double-linked-element :value (funcall function (dle-value dle-object)) + :previous (dle-previous dle-object) + :next (dle-map function (dle-next dle-object))))) + +(defmacro do-dle ((var dle &optional (result nil)) &body body) + "Iterate over a list of DOUBLE-LINKED-ELEMENTs and map body to +each element's value. Bind VAR to the value on each iteration." + (be cursor (gensym) + `(do ((,cursor ,dle (dle-next ,cursor))) + ((not ,cursor) ,result) + (be ,var (dle-value ,cursor) + ,@body)))) + +(defmacro do-dle* ((var dle &optional (result nil)) &body body) + "Same as DO-DLE but VAR is a symbol macro, so that BODY can +modify the element's value." + (be cursor (gensym) + `(symbol-macrolet ((,var (dle-value ,cursor))) + (do ((,cursor ,dle (dle-next ,cursor))) + ((not ,cursor) ,result) + ,@body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass double-linked-list () + ((elements :type double-linked-element + :documentation "The actual list of elements held by this object.") + (last-element :type double-linked-element)) + (:documentation + "A double linked list where elements can be added or removed +from either end.")) + +(defmethod initialize-instance ((object double-linked-list) &rest rest) + (declare (ignorable rest)) + (call-next-method) + (with-slots (last-element elements) object + (setf last-element (make-double-linked-element) + elements last-element))) + +(defmethod print-object ((object double-linked-list) stream) + (print-unreadable-object (object stream :type t) + (be elements '() + (do-dle (e (slot-value object 'elements)) + (push e elements)) + (format stream "elements=~S" (nreverse elements))))) + +(defgeneric pop-first (double-linked-list) + (:documentation + "Pop the first element of a double-linked-list.")) +(defgeneric pop-last (double-linked-list) + (:documentation + "Pop the last element of a double-linked-list.")) +(defgeneric push-first (item double-linked-list) + (:documentation + "Push an item in front of a double-linked-list.")) +(defgeneric push-last (item double-linked-list) + (:documentation + "Append an item to a double-linked-list.")) +(defgeneric list-map (function double-linked-list) + (:documentation + "Map a function to a double-linked-list.")) +(defgeneric dll-find-cursor (object dll &key test key)) +(defgeneric dll-find (object dll &key test key)) +(defgeneric dll-remove (cursor dll)) + +(defmethod pop-last ((list double-linked-list)) + "Drop the last element in the dl list." + (with-slots (last-element) list + (awhen (dle-previous last-element) + (dle-remove it) + (dle-value it)))) + +(defmethod pop-first ((list double-linked-list)) + "Drop the first element in the dl list." + (with-slots (elements) list + (when (dle-next elements) + (prog1 (dle-value elements) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))))) + +(defmethod push-first (value (list double-linked-list)) + (with-slots (elements) list + (setf elements (cons-dle value nil elements))) + list) + +(defmethod push-last (value (list double-linked-list)) + (with-slots (last-element) list + (cons-dle value (dle-previous last-element) last-element)) + list) + +(defmethod list-map (function (list double-linked-list)) + (labels ((map-dll (dle) + (when (dle-next dle) + (make-double-linked-element + :value (funcall function (dle-value dle)) + :previous (dle-previous dle) + :next (map-dll (dle-next dle)))))) + (map-dll (slot-value list 'elements)))) + +(defmethod dll-find-cursor (object (list double-linked-list) &key (test #'eql) (key #'identity)) + (do ((cursor (slot-value list 'elements) (dle-next cursor))) + ((not (dle-next cursor))) + (be value (dle-value cursor) + (when (funcall test (funcall key value) object) + (return cursor))))) + +(defmethod dll-find (object (list double-linked-list) &key (test #'eql) (key #'identity)) + (awhen (dll-find-cursor object list :test test :key key) + (dle-value it))) + +(defmethod dll-remove ((cursor double-linked-element) (list double-linked-list)) + (with-slots (elements) list + (if (dle-previous cursor) + (dle-remove cursor) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))) + list) + +(defmacro do-dll ((var list &optional (result nil)) &body body) + "Iterate over a dll and map body to each element's +value. Bind VAR to the value on each iteration." + (be cursor (gensym) + `(do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) + ((not (dle-next ,cursor)) ,result) + (be ,var (dle-value ,cursor) + ,@body)))) + +(defmacro do-dll* ((var list &optional (result nil)) &body body) + "Same as DO-DLL but VAR is a symbol macro, so that BODY can +modify the element's value." + (be cursor (gensym) + `(symbol-macrolet ((,var (dle-value ,cursor))) + (do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) + ((not (dle-next ,cursor)) ,result) + ,@body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass limited-list (double-linked-list) + ((max-size :initform nil + :initarg :size + :reader max-size + :type (or integer null) + :documentation "Size limit to which the list is allowed to grow to. NIL = no limit.") + (size :initform 0 + :reader size + :type integer + :documentation "Current number of elements in the list.")) + (:documentation + "A double linked list where the maximum number of elements can +be limited.")) + +(defun dll-member-p (dle list) + (with-slots (elements size) list + (do ((e elements (dle-next e))) + ((not e)) + (when (eq e dle) + (return t))))) + +(defmethod dll-remove ((cursor double-linked-element) (list limited-list)) + (with-slots (size) list + (unless (zerop size) + (decf size) + (call-next-method))) + list) + +(defmethod pop-first ((list limited-list)) + (with-slots (size) list + (unless (zerop size) + (decf size) + (call-next-method)))) + +(defmethod pop-last ((list limited-list)) + (with-slots (size) list + (unless (zerop size) + (decf size) + (call-next-method)))) + +(defmethod push-first (value (list limited-list)) + "Add in front of the list and drop the last element if list is +full." + (declare (ignore value)) + (prog1 (call-next-method) + (with-slots (max-size size last-element) list + (if (or (not max-size) + (< size max-size)) + (incf size) + (dle-remove (dle-previous last-element)))))) + +(defmethod push-last (value (list limited-list)) + "Add at the end of the list and drop the first element if list +is full." + (declare (ignore value)) + (prog1 (call-next-method) + (with-slots (max-size size elements) list + (if (or (not max-size) + (< size max-size)) + (incf size) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass sorted-list (limited-list) + ((test :type function + :initarg :test)) + (:documentation + "A double linked list where elements are inserted in a +sorted order.")) + +(defgeneric insert (item sorted-list) + (:documentation + "Insert an item in a sorted-list.")) + +(defmethod insert (item (sl sorted-list)) + "Insert ITEM in SL, which is a sorted double linked list, +before the item for which TEST is true or at the end of the list. +Returns two values, the modified list and the cursor to the new +element." + (with-slots (max-size size elements test last-element) sl + (do ((cursor elements (dle-next cursor))) + ((or (not (dle-next cursor)) + (funcall test item (dle-value cursor))) + (if (dle-previous cursor) + (cons-dle item (dle-previous cursor) cursor) + (setf elements (cons-dle item nil cursor))) + (if (or (not max-size) + (< size max-size)) + (incf size) + (dle-remove (dle-previous last-element))) + (values sl (dle-previous cursor)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass heap () + ((less-than :type function + :initarg :test + :documentation "The heap invariant.") + (data :type array + :documentation "The heap tree representation."))) + +(defmethod initialize-instance ((heap heap) &rest args) + (declare (ignore args)) + (call-next-method) + (with-slots (data) heap + (setf data (make-array 0 :fill-pointer 0 :adjustable t)))) + +(defgeneric heap-add (heap item)) + +(defun bubble-up (heap pos) + (with-slots (data less-than) heap + (loop + for current = pos then parent + for parent = (truncate (1- current) 2) + until (or (zerop current) + (funcall less-than (aref data parent) (aref data current))) + do (rotatef (aref data current) (aref data parent))))) + +(defmethod heap-add ((heap heap) item) + (with-slots (data) heap + (vector-push-extend item data) + (bubble-up heap (1- (fill-pointer data))))) + +(defgeneric heap-size (heap)) + +(defmethod heap-size ((heap heap)) + (fill-pointer (slot-value heap 'data))) + +(defgeneric heap-empty-p (heap)) + +(defmethod heap-empty-p ((heap heap)) + (zerop (heap-size heap))) + + +(defgeneric heap-pop (heap)) + +(defun percolate-down (heap pos) + (with-slots (data less-than) heap + (loop + with end = (fill-pointer data) + for current = pos then child + for left-child = (+ 1 (* 2 current)) + for right-child = (+ 2 (* 2 current)) + for child = (cond ((>= left-child end) + (return)) + ((>= right-child end) + left-child) + ((funcall less-than (aref data left-child) (aref data right-child)) + left-child) + (t + right-child)) + while (funcall less-than (aref data child) (aref data current)) + do (rotatef (aref data current) (aref data child))))) + +(defmethod heap-pop ((heap heap)) + (assert (not (heap-empty-p heap))) + (with-slots (data) heap + (be root (aref data 0) + (setf (aref data 0) (vector-pop data)) + (percolate-down heap 0) + root))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (lru-cache-slot (:include double-linked-element) + (:conc-name lruc-slot-)) + key) + +(defmethod print-object ((object lru-cache-slot) stream) + (print-unreadable-object (object stream :type t) + (format stream "key=~S value=~S" (lruc-slot-key object) (lruc-slot-value object)))) + +(defvar *default-cache-size* 100 + "Default size of a LRU cache if it's not specified at instantiation +time.") + +(defclass lru-cache () + ((max-size :initform *default-cache-size* + :initarg :size + :reader max-size + :type (or integer null) + :documentation + "Maximum number of elements that the cache can fit.") + (elements-list :type lru-cache-slot + :documentation "The list of elements held by the cache.") + (elements-hash :type hash-table + :documentation "The hash table of the elements held bye the cache.") + (last-element :type lru-cache-slot) + (size :initform 0 + :reader size + :type integer + :documentation "Current number of elements in the cache.") + (finalizer :initform nil + :initarg :finalizer + :documentation + "Procedure to call when elements are dropped from cache.")) + (:documentation + "An objects cache that keeps the elements used more often and +drops those that are used less often. The usage is similar to an +hash table. Elements are added to the list up to MAX-SIZE, then +any new element will drop the less used one in the cache. Every +time an element is set or retrieved it goes in front of a list. +Those which get at the end of the list are dropped when more room +is required.")) + +(defmethod initialize-instance ((object lru-cache) &key test &allow-other-keys) + (call-next-method) + (with-slots (last-element elements-list elements-hash) object + (setf last-element (make-lru-cache-slot) + elements-list last-element + elements-hash (if test + (make-hash-table :test test) + (make-hash-table))))) + +(defgeneric getcache (key cache) + (:documentation + "Get an item with KEY from a CACHE.")) + +(defgeneric (setf getcache) (value key cache) + (:documentation + "Set or add an item with KEY in a CACHE.")) + +(defgeneric remcache (key cache) + (:documentation + "Remove an item with KEY from a CACHE.")) + +(defun move-in-front-of-cache-list (slot cache) + "Relocate slot to the front of the elements list in cache. +This will stretch its lifespan in the cache." + (declare (type lru-cache-slot slot) + (type lru-cache cache)) + (with-slots (elements-list) cache + ;; unless it's already the first + (unless (eq slot elements-list) + ;; remove the slot from its original place... + (dle-remove slot) + ;; ... and add it in front of the list + (setf (lruc-slot-next slot) elements-list + (lruc-slot-previous slot) nil + (lruc-slot-previous elements-list) slot + elements-list slot)))) + +(defun drop-last-cache-element (cache) + "Drop the last element in the list of the cache object." + (declare (type lru-cache cache)) + (with-slots (last-element elements-hash finalizer) cache + (let ((second-last (lruc-slot-previous last-element))) + (assert second-last) + (when finalizer + (funcall finalizer (lruc-slot-value second-last))) + (dle-remove second-last) + (remhash (lruc-slot-key second-last) elements-hash)))) + +(defun add-to-cache (slot cache) + (declare (type lru-cache-slot slot) + (type lru-cache cache)) + (move-in-front-of-cache-list slot cache) + (with-slots (max-size size elements-hash) cache + (setf (gethash (lruc-slot-key slot) elements-hash) slot) + (if (and max-size + (< size max-size)) + (incf size) + (drop-last-cache-element cache)))) + +(defmethod getcache (key (cache lru-cache)) + (multiple-value-bind (slot found?) (gethash key (slot-value cache 'elements-hash)) + (when found? + (move-in-front-of-cache-list slot cache) + (values (lruc-slot-value slot) t)))) + +(defmethod (setf getcache) (value key (cache lru-cache)) + (with-slots (elements-hash elements-list) cache + (multiple-value-bind (slot found?) (gethash key elements-hash) + (if found? + (progn + (move-in-front-of-cache-list slot cache) + (setf (lruc-slot-value slot) value)) + (add-to-cache (make-lru-cache-slot :key key :value value) cache)) + value))) + +(defmethod remcache (key (cache lru-cache)) + (with-slots (elements-hash size elements-list finalizer) cache + (multiple-value-bind (slot found?) (gethash key elements-hash) + (when found? + (remhash key elements-hash) + (when finalizer + (funcall finalizer (lruc-slot-value slot))) + (when (eq slot elements-list) + (setf elements-list (dle-next slot))) + (dle-remove slot) + (decf size) + t)))) + +(defmacro cached (cache key value) + "If KEY is found in CACHE return the associated object. Otherwise +store VALUE for later re-use." + (with-gensyms (object my-cache my-key my-value found?) + `(let* ((,my-cache ,cache) + (,my-key ,key)) + (multiple-value-bind (,object ,found?) (getcache ,my-key ,my-cache) + (if ,found? + ,object + (let ((,my-value ,value)) + (setf (getcache ,my-key ,my-cache) ,my-value) + ,my-value)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(declaim (inline list->string)) +(defun list->string (list) + "Coerce a list of characters into a string." + (coerce list 'string)) + +(defun setuid (id) + "Set the Unix real user id." + (when (stringp id) + (setf id (find-uid id))) + #+sbcl (sb-posix:setuid id) + #+cmu (unix:unix-setuid id) + #+clisp (posix::%setuid id) ; not verified -wcp26/8/09. + #-(or cmu sbcl clisp) + (error "setuid unsupported under this Lisp implementation")) + +(defun seteuid (id) + "Set the Unix effective user id." + (when (stringp id) + (setf id (find-uid id))) + #+sbcl (sb-posix:seteuid id) + #+cmu (unix:unix-setreuid -1 id) + #+clisp (posix::%seteuid id) ; not verified -wcp26/8/09. + #-(or cmu sbcl clisp) + (error "seteuid unsupported under this Lisp implementation")) + +(defun find-uid (name) + "Find the user id of NAME. Return an integer." + #+sbcl (awhen (sb-posix:getpwnam name) + (sb-posix:passwd-uid it)) + #+cmu (awhen (unix:unix-getpwnam name) + (unix:user-info-uid it)) + #-(or cmu sbcl) + (error "Unable to find a UID on this Lisp system.")) + +#+clisp (ffi:def-call-out %getuid + (:name "getuid") + (:arguments) + (:return-type ffi:int) + (:library "libc.so")) + +(defun getuid () + "Return the Unix user id. This is an integer." + #+sbcl (sb-unix:unix-getuid) + #+cmu (unix:unix-getuid) + #+clisp (%getuid) + #-(or cmu sbcl clisp) + (error "getuid unsupported under this Lisp implementation")) + +(defun super-user-p (&optional id) + "Return true if the user ID is zero. ID defaults to the current +user id." + (zerop (or id (getuid)))) + +(defmacro with-euid (uid &body forms) + "Switch temporarely to Unix user id UID, while performing FORMS." + (with-gensyms (ruid) + `(be ,ruid (getuid) + (seteuid ,uid) + (unwind-protect (progn ,@forms) + (seteuid ,ruid))))) + +(defun get-logname (&optional uid) + "Return the login id of the user. This is a string and it is not +the Unix uid, which is a number." + (unless uid + (setf uid (getuid))) + (when (stringp uid) + (setf uid (find-uid uid))) + (when uid + #+sbcl (sb-unix:uid-username uid) + #+cmu (unix:user-info-name (unix:unix-getpwuid uid)) + #+clisp (posix:user-info-login-id (posix:user-info uid)) + #-(or cmu sbcl clisp) + (error "get-logname unsupported under this Lisp implementation"))) + +(defun get-user-name (&optional uid) + "Return the user name, taken from the GCOS field of the /etc/passwd +file." + (unless uid + (setf uid (getuid))) + (when (stringp uid) + (setf uid (find-uid uid))) + (when uid + (car (split-string-at-char #+cmu (unix:user-info-gecos (unix:unix-getpwuid uid)) + #+sbcl (sb-posix:passwd-gecos (sb-posix:getpwuid uid)) + #-(or cmu sbcl) (error "can't getpwuid() on this Lisp system.") + #\,)))) + +(defun get-user-home (&optional uid) + (unless uid + (setf uid (getuid))) + (when (stringp uid) + (setf uid (find-uid uid))) + (when uid + #+cmu (unix:user-info-dir (unix:unix-getpwuid uid)) + #+sbcl (sb-posix:passwd-dir (sb-posix:getpwuid uid)))) + +;; Rather stupid, but the mnemonic is worth it +(declaim (inline alist->plist)) +(defun alist->plist (alist) + "Convert an association list into a property list. The alist +elements are assumed to be lists of just two elements: the key +and the value. If the element list is longer this function +doesn't work." + (mapcan #'identity alist)) + +(defun plist->alist (plist &optional pairs-p) + "Convert a property list into an association list. The alist +elements wiil be lists of just two elements: the key and the +value. If PAIRS-P is true the alist elements will be pairs." + (loop + for (key val) on plist by #'cddr + collect (if pairs-p + (cons key val) + (list key val)))) + +(defun string->byte-vector (string &key start end) + "Convert a string of characters into a vector of (unsigned-byte +8) elements." + (map '(vector (unsigned-byte 8)) #'char-code + (if (or start end) + (subseq string (or start 0) end) + string))) + +(defun byte-vector->string (vector &key start end) + "Convert a vector of (unsigned-byte 8) elements into a string +of characters." + (map 'string #'code-char + (if (or start end) + (subseq vector (or start 0) end) + vector))) + +(defun outdated-p (file dependencies) + "Check if FILE has been modified before any of its +DEPENDENCIES." + (be epoch (and (probe-file file) + (file-write-date file)) + ;; if file is missing altogether, we consider it outdated + (or (not epoch) + (loop + for dep in dependencies + thereis (aand (probe-file dep) + (file-write-date dep) + (> it epoch)))))) + +(defmacro let-places (places-and-values &body body) + "Execute BODY binding temporarily some places to new values and +restoring the original values of these places on exit of BODY. The +syntax of this macro is identical to LET. The difference is that +instead of new variable names this macro binds values to existing +places (variables)." + (be tmp-variables (loop for x in places-and-values collect (gensym)) + `(let ,(mapcar #'(lambda (tmp-var place-and-value) + (list tmp-var (car place-and-value))) + tmp-variables places-and-values) + (unwind-protect + (progn + ;; as some assignments could signal an error, we assign + ;; within the unwind-protect block so that we can always + ;; guarantee a consistent state on exit + ,@(mapcar #'(lambda (place-and-value) + `(setf ,(car place-and-value) ,(cadr place-and-value))) + places-and-values) + ,@body) + ,@(mapcar #'(lambda (tmp-var place-and-value) + `(setf ,(car place-and-value) ,tmp-var)) + tmp-variables + places-and-values))))) + +(defmacro let-slots (accessor/new-value-pairs object &body body) + "Execute BODY with some OBJECT's slots temporary sets to new +values as described in ACCESSOR/NEW-VALUE-PAIRS. The latter +should be an alist of accessor names and the value to be assigned +to that slot. On exit from BODY, those slots are restored to +their original value. See LET-PLACES." + (with-gensyms (obj) + `(be ,obj ,object + (let-places ,(mapcar #'(lambda (av) + `((,(car av) ,obj) ,(cadr av))) + accessor/new-value-pairs) + ,@body)))) + +(defvar *decimal-point* #\.) +(defvar *thousands-comma* #\,) + +(defun format-amount (number &key (decimals 2) (rounder #'round) + (comma *thousands-comma*) (comma-stance 3) + (decimal-point *decimal-point*)) + "Return a string formatted as fixed decimal point number of DECIMALS +adding commas every COMMA-STANCE places before the decimal point." + (declare (type number number) + (type fixnum decimals comma-stance) + (type function rounder) + (type character comma decimal-point) + (optimize (speed 3) (safety 0) (debug 0))) + (let* ((int (funcall rounder (* number (expt 10 decimals)))) + (negative (< int 0))) + (declare (integer int)) + (when negative + (setf int (- int))) + (let* ((digits (max (1+ decimals) + (1+ (if (zerop int) + 0 + (truncate (log int 10)))))) + (string-length (+ digits + ;; the minus sign + (if negative 1 0) + ;; the decimal point + (if (zerop decimals) 0 1) + ;; the thousands commas + (1- (ceiling (- digits decimals) comma-stance)))) + (string (make-string string-length)) + (pos (1- string-length))) + (declare (type fixnum pos digits)) + (labels ((add-char (char) + (setf (schar string pos) char) + (decf pos)) + (add-digit () + (add-char (digit-char (mod int 10))) + (setf int (truncate int 10)))) + (unless (zerop decimals) + (loop + for i fixnum from 0 below decimals + do (add-digit)) + (add-char decimal-point)) + (loop + for i fixnum from 1 + do (add-digit) + while (>= pos (if negative 1 0)) + when (zerop (mod i comma-stance)) + do (add-char comma)) + (when negative + (add-char #\-))) + string))) + +(defun parse-amount (string &key (start 0) end) + "Parse STRING as if it was formatted with FORMAT-AMOUNT and return +the parsed number. Return NIL if STRING is malformed. Leading or +trailing spaces must be removed from the string in advance." + (loop + with amount = 0 + with decimals = nil + with negative = (when (and (not (zerop (length string))) + (char= #\- (char string 0))) + (incf start) + t) + for i from start below (or end (length string)) + for c = (char string i) + do (cond ((char= c *decimal-point*) + (if decimals + (return nil) + (setf decimals 0))) + ((char= c *thousands-comma*)) + (t + (be d (digit-char-p c) + (cond ((not d) + (return nil)) + (decimals + (incf decimals) + (incf amount (/ d (expt 10 decimals)))) + (t + (setf amount (+ d (* amount 10)))))))) + finally (return (if negative + (- amount) + amount)))) + +(defmacro with-package (name &body body) + `(let ((*package* (find-package ,name))) + ,@body)) + +(defun bytes-simple-string (n &optional imply-bytes) + "Return a string describing N using a unit of measure multiple +of a byte that is most apporpriate for the magnitude of N. A +kilobyte is 1024 not 1000 bytes, everything follows." + (let* ((kilo 1024) + (mega (* kilo kilo)) + (giga (* kilo mega)) + (tera (* mega mega)) + (peta (* kilo tera))) + (apply #'format nil "~,1F~A" + (cond ((> n (* 2 peta)) + (list (/ n peta) (if imply-bytes "P" "PB"))) + ((> n (* 2 tera)) + (list (/ n tera) (if imply-bytes "T" "TB"))) + ((> n (* 2 giga)) + (list (/ n giga) (if imply-bytes "G" "GB"))) + ((> n (* 2 mega)) + (list (/ n mega) (if imply-bytes "M" "MB"))) + ((> n (* 2 kilo)) + (list (/ n kilo) (if imply-bytes "K" "KB"))) + (t (list n (if imply-bytes "" " bytes"))))))) + +;; WARNING: This function may or may not work on your Lisp system. It +;; all depends on how the OPEN function has been implemented regarding +;; the :IF-EXISTS option. This function requires that OPEN be +;; implemented in a way so that the checking of the existence of file +;; and its open attempt be atomic. If the Lisp OPEN first checks that +;; the file exists and then tries to open it, this function won't be +;; reliable. CMUCL seems to use the O_EXCL open() flag in the right +;; way. So at least on CMUCL this function will work. Same goes for +;; SBCL. +(defun make-lock-files (pathnames &key (sleep-time 7) retries (suspend 13) expiration) + "Create semaphore files. If it can't create all the specified +files in the specified order, it waits SLEEP-TIME seconds and +retries the last file that didn't succeed. You can specify the +number of RETRIES to do until failure is returned. If the number +of retries is NIL this function will retry forever. + +If it tries RETRIES times without success, this function signal +an error and removes all the lock files it created until then. + +All files created by lock file will be read-only. + +If you specify a EXPIRATION then an existing lock file will be +removed by force after EXPIRATION seconds have passed since the +lock file was last modified/created (most likely by some other +program that unexpectedly died without cleaning up its lock +files). After a lock file has been removed by force, a +suspension of SUSPEND seconds is taken into account, in order to +prevent the inadvertent immediate removal of any newly created +lock file by another program." + (be locked '() + (flet ((lock (file) + (when (and expiration + (> (get-universal-time) + (+ (file-write-date file) expiration))) + (delete-file file) + (when suspend + (sleep suspend))) + (do ((i 0 (1+ i)) + (done nil)) + (done) + (unless (or (not retries) + (< i retries)) + (error "Can't create lock file ~S: tried ~A time~:P." file retries)) + (with-open-file (out file :direction :output :if-exists nil) + (cond (out + (format out "Lock file created on ~A~%" (time-string (get-universal-time))) + (setf done t)) + (sleep-time + (sleep sleep-time))))))) + (unwind-protect + (progn + (dolist (file pathnames) + (lock file) + (push file locked)) + (setf locked '())) + (mapc #'delete-file locked))))) + +(defmacro with-lock-files ((lock-files &rest lock-args) &body body) + "Execute BODY after creating LOCK-FILES. Remove the lock files +on exit. LOCK-ARGS are passed to MAKE-LOCK-FILES." + (with-gensyms (files) + `(be ,files (list ,@lock-files) + (make-lock-files ,files ,@lock-args) + (unwind-protect (progn ,@body) + (mapc #'delete-file ,files))))) + +(defun getpid () + #+cmu (unix:unix-getpid) + #+sbcl (sb-unix:unix-getpid) + #+clisp (ext:process-id) + #-(or cmu sbcl clisp) + (error "getpid unsupported under this Lisp implementation")) + +(defmacro on-error (form &body error-forms) + "Execute FORM and in case of error execute ERROR-FORMS too. +This does _not_ stop the error from propagating." + (be done-p (gensym) + `(be ,done-p nil + (unwind-protect + (prog1 + ,form + (setf ,done-p t)) + (unless ,done-p + ,@error-forms))))) + +(defun floor-to (x aim) + "Round X down to the nearest multiple of AIM." + (* (floor x aim) aim)) + +(defun round-to (x aim) + "Round X to the nearest multiple of AIM." + (* (round x aim) aim)) + +(defun ceiling-to (x aim) + "Round X up to the nearest multiple of AIM." + (* (ceiling x aim) aim)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct queue + first + last) + +(defgeneric queue-append (queue objects)) +(defgeneric queue-pop (queue)) +(defgeneric queue-empty-p (queue)) + +(defmethod queue-append ((queue queue) (objects list)) + (cond ((null (queue-first queue)) + (setf (queue-first queue) objects + (queue-last queue) (last objects))) + (t + (setf (cdr (queue-last queue)) objects + (queue-last queue) (last objects)))) + queue) + +(defmethod queue-append ((queue queue) object) + (queue-append queue (list object))) + +(defmethod queue-pop ((queue queue)) + (prog1 (car (queue-first queue)) + (setf (queue-first queue) (cdr (queue-first queue))))) + +(defmethod queue-empty-p ((queue queue)) + (null (queue-first queue))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun package-locked-p (package) + #+sbcl (sb-ext:package-locked-p package) + #+cmu (ext:package-definition-lock package) + #+clisp (ext:package-lock package) + #-(or sbcl cmu clisp) (error "Don't know how to check whether a package might be locked.")) + +(defun forget-documentation (packages) + "Remove documentation from all known symbols in PACKAGES. If +PACKAGES is NIL remove documentations from all packages. This may not +make sense if your Lisp image has been built so that existing objects +don't get garbage collected. It may work for your own code, though. +Locked packages are left alone. If you need to do those too, unlock +them first." + (flet ((forget (symbol) + (dolist (type '(compiler-macro function method-combination setf structure type variable)) + (when (ignore-errors (documentation symbol type)) + (setf (documentation symbol type) nil))))) + (setf packages (mapcar #'(lambda (pkg) + (if (packagep pkg) + (package-name pkg) + (package-name (find-package pkg)))) + packages)) + (setf packages + ;; don't try to modify locked packages + (remove-if #'package-locked-p + (mapcar #'find-package + (or packages + (list-all-packages))))) + (dolist (package packages) + (with-package-iterator (next package :internal :external) + (loop + (multiple-value-bind (more? symbol) (next) + (unless more? + (return)) + (forget symbol))))) + #+(OR) (do-all-symbols (symbol) + (when (member (symbol-package symbol) packages) + (forget symbol)))) + (values)) + +(defun load-compiled (pathname &optional compiled-pathname) + "Make sure to compile PATHNAME before loading it. Don't compile if +the compiled version is more recent than its source." + ;; be tolerant if we didn't get a type + (unless (probe-file pathname) + (setf pathname (merge-pathnames pathname (make-pathname :type "lisp")))) + (if (probe-file pathname) + (progn + (setf compiled-pathname (or compiled-pathname + (compile-file-pathname pathname))) + (when (or (not (probe-file compiled-pathname)) + (< (file-write-date compiled-pathname) + (file-write-date pathname))) + (compile-file pathname)) + (load compiled-pathname)) + (error "Can't load ~A as it doesn't exist." pathname))) + +;; Just a silly mnemonic for those used to lesser languages +(defmacro swap (x y) + "Swap values of places X and Y." + `(rotatef ,x ,y)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro show (&rest things) + "Debugging macro to show the name and content of variables. You can +also specify forms, not just variables." + (let ((*print-pretty* nil)) + `(let ((*print-circle* t)) + (format t ,(format nil "~~&~{~A=~~:W~~%~}" things) + ,@things) + (finish-output) + (values)))) + +(defmacro memoize-function (name &key test) + "Make function NAME memoized. TEST is passed to MAKE-HASH-TABLE." + `(setf (get ',name 'results-hash-table) + (make-hash-table ,@(when test (list :test test))))) + +(defmacro defun-memoized (name args &body forms) + "Define function NAME and make it memoizable. Then the MEMOIZED +macro can be used to call this function and memoize its results. The +function NAME must accept only one argument and return just one +argument; more complicated cases are not considered. The hash table +test function is the default 'EQL." + `(eval-when (:load-toplevel :compile-toplevel) + (defun ,name ,args ,@forms) + (memoize-function ,name))) + +(defmacro memoized (function arg) + "If necessary call FUNCTION passing ARG so that its return value is +memoized. The next time this form is executed with the same argument +value, the memoized result is returned instead of executing FUNCTION." + (with-gensyms (table key result not-found) + `(be* ,key ,arg + ,table (get ',function 'results-hash-table) + ,not-found (list nil) + ,result (gethash ,key ,table ,not-found) + (if (eq ,not-found ,result) + (setf (gethash ,key ,table) + (,function ,key)) + ,result)))) + + +(defmacro save-file-excursion ((stream &optional position) &body forms) + "Execute FORMS returning, on exit, STREAM to the position it was +before FORMS. Optionally POSITION can be set to the starting offset." + (unless position + (setf position (gensym))) + `(be ,position (file-position ,stream) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(defun circular-list (&rest elements) + "Return a circular list of ELEMENTS." + (setf (cdr (last elements)) elements)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun getenv (var) + "Return the string associate to VAR in the system environment." + #+cmu (cdr (assoc (if (symbolp var) + var + (intern var :keyword)) + ext:*environment-list*)) + #+sbcl (sb-ext:posix-getenv (string var)) + #+lispworks (hcl:getenv var) + #+clisp (ext:getenv (string var)) + #-(or cmu sbcl lispworks clisp) + (error "GETENV not implemented for your Lisp system.")) + +#+clisp (ffi:def-call-out %setenv + (:name "setenv") + (:arguments (name ffi:c-string) (value ffi:c-string) (overwrite ffi:int)) + (:return-type ffi:int) + (:library "libc.so")) + +#+clisp (ffi:def-call-out %unsetenv + (:name "unsetenv") + (:arguments (name ffi:c-string)) + (:return-type ffi:int) + (:library "libc.so")) + +(defun setenv (name value &optional (overwrite t)) + (typecase value + (string) + (pathname + (setf value (native-namestring value))) + (t + (setf value (format nil "~A" value)))) + #+sbcl (unless (zerop (sb-posix:setenv name value (if overwrite 1 0))) + (error "unable to setenv ~A: errno=~A." name + (sb-alien:get-errno))) + #+cmu (be key (keywordify name) + (aif (assoc key + ext:*environment-list*) + (when overwrite + (setf (cdr it) value)) + (setf ext:*environment-list* + (cons (cons key value) + ext:*environment-list*)))) + #-(or cmu sbcl) (unless (zerop (%setenv name value (if overwrite 1 0))) + (error "unable to setenv ~A." name))) + +(defun unsetenv (name) + #+sbcl (unless (zerop (sb-posix:unsetenv name)) + (error "unable to unsetenv ~A: errno=~A." name + (sb-alien:get-errno))) + #+cmu (be key (keywordify name) + (setf ext:*environment-list* + (delete-if #'(lambda (e) + (eq (car e) key)) + ext:*environment-list*))) + #-(or cmu sbcl) (unless (zerop (%unsetenv name)) + (error "unable to unsetenv ~A." name))) + +(defun (setf getenv) (value name) + (if value + (setenv name value t) + (unsetenv name))) + +;; in CMUCL it's much easier (see below) +#-cmu +(defmacro with-system-environment ((&rest var-and-values) &body body) + (be gensym-alist (mapcar #'(lambda (vv) + (list (gensym) (string (car vv)) (cadr vv))) + var-and-values) + `(let ,(mapcar #'(lambda (vv) + (destructuring-bind (varsym var value) vv + (declare (ignore value)) + `(,varsym (getenv ,var)))) + gensym-alist) + (unwind-protect + (progn + ,@(mapcar #'(lambda (vv) + (destructuring-bind (varsym var value) vv + (declare (ignore varsym)) + `(setenv ,var ,value))) + gensym-alist) + ,@body) + ,@(mapcar #'(lambda (vv) + (destructuring-bind (varsym var value) vv + (declare (ignore value)) + `(if ,varsym + (setenv ,var ,varsym) + (unsetenv ,var)))) + gensym-alist))))) + +#+cmu +(defmacro with-system-environment ((&rest var-and-values) &body body) + `(let ((ext:*environment-list* + (append (list ,@(mapcar #'(lambda (vv) + (destructuring-bind (variable value) vv + `(cons ,(keywordify variable) + ,value))) + var-and-values)) + ext:*environment-list*))) + ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun last-member (item list &key key (test #'eq)) + "Return the last sublist in LIST that is prefixed by ITEM." + (loop + with l = list and result = nil + for l2 = (member item l :key key :test test) + while l2 + do (setf result l2 + l (cdr l2)) + finally (return result))) + + +(defun glob->regex (string) + "Convert a shell glob expression into a regular expression string." + (with-output-to-string (out) + ;; globs are always anchored to beginning and end + (write-char #\^ out) + (loop + for i from 0 below (length string) + do (be c (char string i) + (cond ((char= c #\\) + (setf c (char string (incf i)))) + ((find c ".+()|^$") + (write-char #\\ out)) + ((char= c #\*) + (write-char #\. out)) + ((char= c #\?) + (setf c #\.))) + (write-char c out))) + (write-char #\$ out))) diff --git a/third_party/lisp/sclf/serial.lisp b/third_party/lisp/sclf/serial.lisp new file mode 100644 index 000000000000..936c61606386 --- /dev/null +++ b/third_party/lisp/sclf/serial.lisp @@ -0,0 +1,62 @@ + ;;; serial.lisp --- serialisation of CLOS objects + + ;;; Copyright (C) 2009 by Walter C. Pelissero + + ;;; Author: Walter C. Pelissero <walter@pelissero.de> + ;;; Project: sclf + +#+cmu (ext:file-comment "$Module: serial.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defclass printable-object-mixin () ()) + +(defmacro reconstruct-object (class &rest args) + `(apply #'make-instance ',class ',args)) + +(defun print-readable-instance (object &optional stream) + (unless stream + (setf stream *standard-output*)) + (be class (class-of object) + (pprint-logical-block (stream (copy-list (class-slots class)) :prefix "#.(" :suffix ")") + (flet ((spc () + (write-char #\space stream))) + (write 'reconstruct-object :stream stream) + (spc) + (write (class-name class) :stream stream :escape t :readably t :pretty t) + (pprint-exit-if-list-exhausted) + (spc) + (loop + (be* slot (pprint-pop) + slot-name (slot-definition-name slot) + initarg (car (slot-definition-initargs slot)) + (when (and initarg + (slot-boundp object slot-name)) + (write initarg :stream stream) + (spc) + (when *print-pretty* + (pprint-newline :miser stream)) + (write (slot-value object slot-name) + :stream stream) + (pprint-exit-if-list-exhausted) + (if *print-pretty* + (pprint-newline :linear stream) + (spc))))))))) + +(defmethod print-object ((object printable-object-mixin) stream) + (if *print-readably* + (print-readable-instance object stream) + (call-next-method))) diff --git a/third_party/lisp/sclf/sysproc.lisp b/third_party/lisp/sclf/sysproc.lisp new file mode 100644 index 000000000000..85c2517e0002 --- /dev/null +++ b/third_party/lisp/sclf/sysproc.lisp @@ -0,0 +1,295 @@ +;;; sysproc.lisp --- system processes + +;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: sysproc.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defvar *bourne-shell* "/bin/sh") + +(defvar *run-verbose* nil + "If true system commands are displayed before execution and standard +error is not discarded.") + +;; +;; SIGINFO is missing in both CMUCL and SBCL +;; + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant unix::siginfo 29) + (defvar siginfo (unix::make-unix-signal :siginfo unix::siginfo "Information")) + (export '(unix::siginfo) "UNIX") + (pushnew siginfo unix::*unix-signals*)) + +#+sbcl (in-package :sb-posix) +#+sbcl +(eval-when (:execute :compile-toplevel :load-toplevel) + (unless (find-symbol "SIGINFO" :sb-posix) + (sb-ext:with-unlocked-packages (:sb-posix) + (defvar siginfo 29) + (export '(SIGINFO))))) +#+sbcl (in-package :sclf) + +(defun signal-number (signal-name) + (ecase signal-name + ((:abrt :abort) + #+cmu unix:sigabrt + #+sbcl sb-posix:sigabrt) + ((:alrm :alarm) + #+cmu unix:sigalrm + #+sbcl sb-posix:sigalrm) + ((:bus :bus-error) + #+cmu unix:sigbus + #+sbcl sb-posix:sigbus) + ((:chld :child) + #+cmu unix:sigchld + #+sbcl sb-posix:sigchld) + ((:cont :continue) + #+cmu unix:sigcont + #+sbcl sb-posix:sigcont) + #+freebsd((:emt :emulate-instruction) + #+cmu unix:sigemt + #+sbcl sb-posix:sigemt) + ((:fpe :floating-point-exception) + #+cmu unix:sigfpe + #+sbcl sb-posix:sigfpe) + ((:hup :hangup) + #+cmu unix:sighup + #+sbcl sb-posix:sighup) + ((:ill :illegal :illegal-instruction) + #+cmu unix:sigill + #+sbcl sb-posix:sigill) + ((:int :interrupt) + #+cmu unix:sigint + #+sbcl sb-posix:sigint) + ((:io :input-output) + #+cmu unix:sigio + #+sbcl sb-posix:sigio) + (:kill + #+cmu unix:sigkill + #+sbcl sb-posix:sigkill) + ((:pipe :broke-pipe) + #+cmu unix:sigpipe + #+sbcl sb-posix:sigpipe) + ((:prof :profiler) + #+cmu unix:sigprof + #+sbcl sb-posix:sigprof) + (:quit + #+cmu unix:sigquit + #+sbcl sb-posix:sigquit) + ((:segv :segmentation-violation) + #+cmu unix:sigsegv + #+sbcl sb-posix:sigsegv) + (:stop + #+cmu unix:sigstop + #+sbcl sb-posix:sigstop) + ((:sys :system-call) + #+cmu unix:sigsys + #+sbcl sb-posix:sigsys) + ((:term :terminate) + #+cmu unix:sigterm + #+sbcl sb-posix:sigterm) + ((:trap) + #+cmu unix:sigtrap + #+sbcl sb-posix:sigtrap) + ((:tstp :terminal-stop) + #+cmu unix:sigtstp + #+sbcl sb-posix:sigtstp) + ((:ttin :tty-input) + #+cmu unix:sigttin + #+sbcl sb-posix:sigttin) + ((:ttou :tty-output) + #+cmu unix:sigttou + #+sbcl sb-posix:sigttou) + ((:urg :urgent) + #+cmu unix:sigurg + #+sbcl sb-posix:sigurg) + ((:usr1 :user1) + #+cmu unix:sigusr1 + #+sbcl sb-posix:sigusr1) + ((:usr2 :user2) + #+cmu unix:sigusr2 + #+sbcl sb-posix:sigusr2) + ((:vtalrm :virtual-timer-alarm) + #+cmu unix:sigvtalrm + #+sbcl sb-posix:sigvtalrm) + ((:winch :window-change :window-size-change) + #+cmu unix:sigwinch + #+sbcl sb-posix:sigwinch) + ((:xcpu :exceeded-cpu) + #+cmu unix:sigxcpu + #+sbcl sb-posix:sigxcpu) + ((:xfsz :exceeded-file-size) + #+cmu unix:sigxfsz + #+sbcl sb-posix:sigxfsz) + ;; oddly this is not defined by neither CMUCL nor SBCL + (:info 29))) + +(defun sysproc-kill (process signal) + (when (keywordp signal) + (setf signal (signal-number signal))) + #+cmu (ext:process-kill process signal) + #+sbcl (sb-ext:process-kill process signal) + #-(or sbcl cmu) (error "Don't know how to kill a process")) + +(defun sysproc-exit-code (process) + #+cmu (ext:process-exit-code process) + #+sbcl (sb-ext:process-exit-code process) + #-(or sbcl cmu) (error "Don't know how to get a process exit code")) + +(defun sysproc-wait (process) + #+cmu (ext:process-wait process) + #+sbcl (sb-ext:process-wait process) + #-(or sbcl cmu) (error "Don't know how to wait a process")) + +(defun sysproc-input (process) + #+cmu (ext:process-input process) + #+sbcl (sb-ext:process-input process) + #-(or sbcl cmu) (error "Don't know how to get the process input")) + +(defun sysproc-output (process) + #+cmu (ext:process-output process) + #+sbcl (sb-ext:process-output process) + #-(or sbcl cmu) (error "Don't know how to get the process output")) + +(defun sysproc-alive-p (process) + #+cmu (ext:process-alive-p process) + #+sbcl (sb-ext:process-alive-p process) + #-(or sbcl cmu) (error "Don't know how to test wether a process might be running")) + +(defun sysproc-pid (process) + #+cmu (ext:process-pid process) + #+sbcl (sb-ext:process-pid process) + #-(or sbcl cmu) (error "Don't know how to get the id of a process")) + +(defun sysproc-p (thing) + #+sbcl (sb-ext:process-p thing) + #+cmu (ext:process-p thing) + #-(or sbcl cmu) (error "Don't know how to figure out whether something is a system process")) + +(defun run-program (program arguments &key (wait t) pty input output error) + "Run PROGRAM with ARGUMENTS (a list) and return a process object." + ;; convert arguments to strings + (setf arguments + (mapcar #'(lambda (item) + (typecase item + (string item) + (pathname (native-namestring item)) + (t (format nil "~A" item)))) + arguments)) + (when *run-verbose* + (unless error + (setf error t)) + (format t "~&; run-pipe ~A~{ ~S~}~%" program arguments)) + #+cmu (ext:run-program program arguments + :wait wait + :pty pty + :input input + :output output + :error (or error *run-verbose*)) + #+sbcl (sb-ext:run-program program arguments + :search t + :wait wait + :pty pty + :input input + :output output + :error (or error *run-verbose*)) + #-(or sbcl cmu) + (error "Unsupported Lisp system.")) + +(defun run-pipe (direction program arguments &key error) + "Run PROGRAM with a list of ARGUMENTS and according to DIRECTION +return the input and output streams and process object of that +process." + (be process (run-program program arguments + :wait nil + :pty nil + :input (when (member direction '(:output :input-output :io)) + :stream) + :output (when (member direction '(:input :input-output :io)) + :stream) + :error error) + (values (sysproc-output process) + (sysproc-input process) + process)) + #-(or sbcl cmu) + (error "Unsupported Lisp system.")) + +(defun exit-code (process) + (sysproc-wait process) + (sysproc-exit-code process)) + +(defun run-shell-command (fmt &rest args) + "Run a Bourne Shell command. Return the exit status of the command." + (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args)))) + +(defun run-async-shell-command (fmt &rest args) + "Run a Bourne Shell command asynchronously. Return a process +object if provided by your Lisp implementation." + (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args)) + :wait nil)) + +(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms) + "Run BODY with IN and OUT bound respectively to an input and an +output stream connected to a system process created by running PROGRAM +with ARGUMENTS. If IN or OUT are NIL, then don't create that stream." + (with-gensyms (prg args) + `(be* ,prg ,program + ,args ,arguments + ,process (run-program ,prg ,args + :output ,(case in + ((t nil) in) + (t :stream)) + :input ,(case out + ((t nil) out) + (t :stream)) + :wait nil + :pty ,pty + ,@(when error `(:error ,error))) + (if ,process + (let (,@(case in + ((t nil)) + (t `((,in (sysproc-output ,process))))) + ,@(case out + ((t nil)) + (t `((,out (sysproc-input ,process)))))) + (unwind-protect + (progn + ,@forms) + ,@(case in + ((t nil)) + (t `((close ,in)))) + ,@(case out + ((t nil)) + (t `((close ,out)))) + (when (sysproc-alive-p ,process) + (sysproc-kill ,process :term)))) + (error "unable to run ~A~{ ~A~}." ,prg ,args))))) + + +(defun sysproc-set-signal-callback (signal handler) + "Arrange HANDLER function to be called when receiving the system +signal SIGNAL." + (when (keywordp signal) + (setf signal (signal-number signal))) + #+cmu (system:enable-interrupt signal handler) + #+sbcl (sb-sys:enable-interrupt signal handler) + #-(or cmu sbcl) (error "Don't know how to set a system signal callback.")) diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp new file mode 100644 index 000000000000..ca1e1902a92c --- /dev/null +++ b/third_party/lisp/sclf/time.lisp @@ -0,0 +1,311 @@ +;;; time.lisp --- time primitives + +;;; Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: time.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defun year (epoch &optional time-zone) + "Return the year of EPOCH." + (sixth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun month (epoch &optional time-zone) + "Return the month of EPOCH." + (fifth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun day (epoch &optional time-zone) + "Return the day of EPOCH." + (fourth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun week-day (epoch &optional time-zone) + "Return the day of the week of EPOCH." + (seventh (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun hour (epoch &optional time-zone) + "Return the hour of EPOCH." + (third (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun minute (epoch &optional time-zone) + "Return the minute of EPOCH." + (second (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun leap-year-p (year) + "Return true if YEAR is a leap year." + (and (zerop (mod year 4)) + (or (not (zerop (mod year 100))) + (zerop (mod year 400))))) + +(defun last-day-of-month (month year) + "Return the last day of the month as integer." + (be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)) + (if (and (= last 28) + (leap-year-p year)) + (1+ last) + last))) + +(defun add-months (months epoch &optional time-zone) + "Add MONTHS to EPOCH, which is a universal time. MONTHS can be +negative." + (multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone) + (multiple-value-bind (y m) (floor (+ month months -1) 12) + (let ((new-month (1+ m)) + (new-year (+ year y))) + (encode-universal-time ss mm hh + (min day (last-day-of-month new-month (year epoch))) + new-month + new-year + time-zone))))) + +(defun add-days (days epoch) + "Add DAYS to EPOCH, which is an universal time. DAYS can be +negative." + (+ (* 60 60 24 days) epoch)) + +;; The following two functions are based on Thomas Russ <tar@isi.edu> +;; code which didn't carry any copyright notice, so I assume it was in +;; the public domain. + +(defun iso-time-string (time &key time-zone with-timezone-p basic) + "Return an ISO 8601 string representing TIME. The time zone is +included if WITH-TIMEZONE-P is true." + (flet ((format-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Sign of time zone is reversed in ISO 8601 relative + ;; to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round m)))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time time-zone) + (declare (ignore dow dst)) + (if basic + (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)))))) + +(defun parse-iso-time-string (time-string) + "Parse an ISO 8601 formated string and return the universal time. +It can parse the basic and the extended format, but may not be able to +cover all the cases." + (labels ((parse-delimited-string (string delimiter n) + ;; Parses a delimited string and returns a list of + ;; n integers found in that string. + (let ((answer (make-list n :initial-element 0))) + (loop + for i upfrom 0 + for start = 0 then (1+ end) + for end = (position delimiter string :start (1+ start)) + do (setf (nth i answer) + (parse-integer (subseq string start end))) + when (null end) return t) + (values-list answer))) + (parse-fixed-field-string (string field-sizes) + ;; Parses a string with fixed length fields and returns + ;; a list of integers found in that string. + (let ((answer (make-list (length field-sizes) :initial-element 0))) + (loop + with len = (length string) + for start = 0 then (+ start field-size) + for field-size in field-sizes + for i upfrom 0 + while (< start len) + do (setf (nth i answer) + (parse-integer (subseq string start (+ start field-size))))) + (values-list answer))) + (parse-iso8601-date (date-string) + (let ((hyphen-pos (position #\- date-string))) + (if hyphen-pos + (parse-delimited-string date-string #\- 3) + (parse-fixed-field-string date-string '(4 2 2))))) + (parse-iso8601-timeonly (time-string) + (let* ((colon-pos (position #\: time-string)) + (zone-pos (or (position #\- time-string) + (position #\+ time-string))) + (timeonly-string (subseq time-string 0 zone-pos)) + (zone-string (when zone-pos (subseq time-string (1+ zone-pos)))) + (time-zone nil)) + (when zone-pos + (multiple-value-bind (zone-h zone-m) + (parse-delimited-string zone-string #\: 2) + (setq time-zone (+ zone-h (/ zone-m 60))) + (when (char= (char time-string zone-pos) #\-) + (setq time-zone (- time-zone))))) + (multiple-value-bind (hh mm ss) + (if colon-pos + (parse-delimited-string timeonly-string #\: 3) + (parse-fixed-field-string timeonly-string '(2 2 2))) + (values hh mm ss time-zone))))) + (let ((time-separator (position #\T time-string))) + (multiple-value-bind (year month date) + (parse-iso8601-date + (subseq time-string 0 time-separator)) + (if time-separator + (multiple-value-bind (hh mm ss zone) + (parse-iso8601-timeonly + (subseq time-string (1+ time-separator))) + (if zone + ;; Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (encode-universal-time ss mm hh date month year (- zone)) + (encode-universal-time ss mm hh date month year))) + (encode-universal-time 0 0 0 date month year)))))) + +(defun time-string (time &optional time-zone) + "Return a string representing TIME in the form: + Tue Jan 25 12:55:40 2005" + (multiple-value-bind (ss mm hh day month year week-day) + (decode-universal-time time time-zone) + (format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A" + (subseq (week-day->string week-day) 0 3) + (subseq (month->string month) 0 3) + day + hh mm ss + year))) + +(defun beginning-of-month (month year &optional time-zone) + (encode-universal-time 0 0 0 1 month year time-zone)) + +(defun end-of-month (month year &optional time-zone) + (1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone)))) + +(defun beginning-of-first-week (year &optional time-zone) + "Return the epoch of the first week of YEAR. As the first week +of the year needs to have Thursday in this YEAR, the returned +time can actually fall in the previous year." + (let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone)) + (start (- 4 (week-day (add-days 4 Jan-1st))))) + (add-days start Jan-1st))) + +(defun beginning-of-week (week year &optional time-zone) + "Return the epoch of the beginning of WEEK of YEAR." + (add-days (* (1- week) 7) (beginning-of-first-week year time-zone))) + +(defun end-of-week (week year &optional time-zone) + "Return the epoch of the beginning of WEEK of YEAR." + (1- (beginning-of-week (1+ week) year time-zone))) + +(defun end-of-last-week (year &optional time-zone) + "Return the epoch of the last week of YEAR. As the last week +of the year needs to have Thursday in this YEAR, the returned +time can fall in the next year." + (1- (beginning-of-first-week (1+ year) time-zone))) + +(defun seconds-from-beginning-of-the-year (time &optional time-zone) + (- time (encode-universal-time 0 0 0 1 1 (year time) time-zone))) + +(defun day-of-the-year (time &optional time-zone) + "Return the day within the year of TIME starting from 1 up to +365 (or 366)." + (1+ (truncate (seconds-from-beginning-of-the-year time time-zone) + (* 60 60 24)))) + +(defun week (time &optional time-zone) + "Return the number of the week and the year TIME referes to. +Week is an integer from 1 to 52. Due to the way the first week +of the year is calculated a day in one year could actually be in +the last week of the previous or next year." + (let* ((year (year time)) + (start (beginning-of-first-week year time-zone)) + (days-from-start (truncate (- time start) (* 60 60 24))) + (weeks (truncate days-from-start 7)) + (week-number (mod weeks 52))) + (values (1+ week-number) + (cond ((< weeks 0) + (1- year)) + ((> weeks 51) + (1+ year)) + (t year))))) + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) + +(defun month-string->number (month) + (1+ (position month +month-names+ :test #'string-equal))) + +(defun print-time-span (span &optional stream) + "Print in English the time SPAN expressed in seconds." + (let* ((minute 60) + (hour (* minute 60)) + (day (* hour 24)) + (seconds span)) + (macrolet ((split (divisor) + `(when (>= seconds ,divisor) + (prog1 (truncate seconds ,divisor) + (setf seconds (mod seconds ,divisor)))))) + (let* ((days (split day)) + (hours (split hour)) + (minutes (split minute))) + (format stream "~{~A~^ ~}" (remove nil + (list + (when days + (format nil "~D day~:P" days)) + (when hours + (format nil "~D hour~:P" hours)) + (when minutes + (format nil "~D minute~:P" minutes)) + (when (or (> seconds 0) + (= span 0)) + (format nil "~D second~:P" seconds))))))))) + +(defun next-week-day (epoch week-day &optional time-zone) + "Return the universal time of the next WEEK-DAY starting from epoch." + (add-days (mod (- week-day (week-day epoch time-zone)) 7) + epoch)) + +(defun next-monday (epoch &optional time-zone) + "Return the universal time of the next Monday starting from +EPOCH." + (next-week-day epoch 0 time-zone)) + +(defun full-weeks-in-span (start end &optional time-zone) + "Return the number of full weeks in time span START to END. A +full week starts on Monday and ends on Sunday." + (be first-monday (next-monday start time-zone) + (truncate (- end first-monday) (* 7 24 60 60)))) + +(defconst +unix-lisp-time-difference+ + (encode-universal-time 0 0 0 1 1 1970 0) + "Time difference between Unix epoch and Common Lisp epoch. The +former is 1st January 1970, while the latter is the beginning of the +XX century.") + +(defun universal->unix-time (time) + (- time +unix-lisp-time-difference+)) + +(defun unix->universal-time (time) + (+ time +unix-lisp-time-difference+)) + +(defun get-unix-time () + (universal->unix-time (get-universal-time))) diff --git a/third_party/lisp/split-sequence.nix b/third_party/lisp/split-sequence.nix new file mode 100644 index 000000000000..105646386fd3 --- /dev/null +++ b/third_party/lisp/split-sequence.nix @@ -0,0 +1,18 @@ +# split-sequence is a library for, well, splitting sequences apparently. +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/sharplispers/split-sequence.git"; + rev = "41c0fc79a5a2871d16e5727969a8f699ef44d791"; +}; +in depot.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 000000000000..391b10e5db65 --- /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 000000000000..3798a6664a3d --- /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 000000000000..bdd057cade27 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/default.nix @@ -0,0 +1,14 @@ +# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git +{ depot, ... }: + +depot.nix.buildLisp.library { + name = "trivial-backtrace"; + + 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 000000000000..aa3951e30f9f --- /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 000000000000..40a5219824e5 --- /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 000000000000..43eddda47579 --- /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 000000000000..2be26a5a870e --- /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 000000000000..2da49d3d9ba5 --- /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 000000000000..b0a249867aa9 --- /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 000000000000..0f22312080cf --- /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 000000000000..7dc3eae57682 --- /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 000000000000..a46b3a196649 --- /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 000000000000..9b32090f13e0 --- /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 000000000000..cb088434a2c1 --- /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 000000000000..843b6cc39a3c --- /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 000000000000..93a5df3b91db --- /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 000000000000..c5bf3c4ec399 --- /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 000000000000..2738c471378c --- /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 000000000000..a734edfb8323 --- /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 000000000000..01b745ba44c0 --- /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 000000000000..13a63bab1aba --- /dev/null +++ b/third_party/lisp/trivial-features.nix @@ -0,0 +1,16 @@ +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/trivial-features/trivial-features.git"; + rev = "f6e8dd7268ae0137dbde4be469101a7f735f6416"; # 2021-02-28 +}; +in depot.nix.buildLisp.library { + name = "trivial-features"; + srcs = [ + { + sbcl = src + "/src/tf-sbcl.lisp"; + ecl = src + "/src/tf-ecl.lisp"; + ccl = src + "/src/tf-openmcl.lisp"; + } + ]; +} diff --git a/third_party/lisp/trivial-garbage.nix b/third_party/lisp/trivial-garbage.nix new file mode 100644 index 000000000000..e5b3550de7ba --- /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 +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/trivial-garbage/trivial-garbage.git"; + rev = "dbc8e35acb0176b9a14fdc1027f5ebea93435a84"; +}; +in depot.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 000000000000..b5722f9a685a --- /dev/null +++ b/third_party/lisp/trivial-gray-streams.nix @@ -0,0 +1,16 @@ +# Portability library for CL gray streams. +{ depot, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/trivial-gray-streams/trivial-gray-streams.git"; + rev = "ebd59b1afed03b9dc8544320f8f432fdf92ab010"; +}; +in depot.nix.buildLisp.library { + name = "trivial-gray-streams"; + srcs = [ + (src + "/package.lisp") + (src + "/streams.lisp") + ]; +} + + diff --git a/third_party/lisp/trivial-indent.nix b/third_party/lisp/trivial-indent.nix new file mode 100644 index 000000000000..65d98604d78c --- /dev/null +++ b/third_party/lisp/trivial-indent.nix @@ -0,0 +1,17 @@ + +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "Shinmera"; + repo = "trivial-indent"; + rev = "2d016941751647c6cc5bd471751c2cf68861c94a"; + sha256 = "1sj90nqz17w4jq0ixz00gb9g5g6d2s7l8r17zdby27gxxh51w266"; + }; +in depot.nix.buildLisp.library { + name = "trivial-indent"; + + srcs = map (f: src + ("/" + f)) [ + "indent.lisp" + ]; +} diff --git a/third_party/lisp/trivial-ldap.nix b/third_party/lisp/trivial-ldap.nix new file mode 100644 index 000000000000..c8a27431c687 --- /dev/null +++ b/third_party/lisp/trivial-ldap.nix @@ -0,0 +1,26 @@ +{ depot, pkgs, ... }: + +let src = pkgs.fetchFromGitHub { + owner = "rwiker"; + repo = "trivial-ldap"; + rev = "3b8f1ff85f29ea63e6ab2d0d27029d68b046faf8"; + sha256 = "1zaa4wnk5y5ff211pkg6dl27j4pjwh56hq0246slxsdxv6kvp1z9"; + }; +in depot.nix.buildLisp.library { + name = "trivial-ldap"; + + deps = with depot.third_party.lisp; [ + usocket + cl-plus-ssl + cl-yacc + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "trivial-ldap.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/trivial-mimes.nix b/third_party/lisp/trivial-mimes.nix new file mode 100644 index 000000000000..ce45993d05e9 --- /dev/null +++ b/third_party/lisp/trivial-mimes.nix @@ -0,0 +1,30 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "Shinmera"; + repo = "trivial-mimes"; + rev = "a741fc2f567a4f86b853fd4677d75e62c03e51d9"; + sha256 = "00kcm17q5plpzdj1qwg83ldhxksilgpcdkf3m9azxcdr968xs9di"; + }; + + mime-types = pkgs.runCommand "mime-types.lisp" {} '' + substitute ${src}/mime-types.lisp $out \ + --replace /etc/mime.types ${src}/mime.types \ + --replace "(asdf:system-source-directory :trivial-mimes)" '"/bogus-dir"' + # We want to prevent an ASDF lookup at build time since this will + # generally fail — we are not using ASDF after all. + ''; + +in depot.nix.buildLisp.library { + name = "trivial-mimes"; + + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + ]; + + srcs = [ mime-types ]; +} diff --git a/third_party/lisp/uax-15.nix b/third_party/lisp/uax-15.nix new file mode 100644 index 000000000000..a13e5c1690d3 --- /dev/null +++ b/third_party/lisp/uax-15.nix @@ -0,0 +1,45 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) runCommand; + inherit (depot.nix.buildLisp) bundled; + + src = pkgs.fetchFromGitHub { + owner = "sabracrolleton"; + repo = "uax-15"; + rev = "a62fc7253663fac6467fc6b6bb69a73a0e8dfaa0"; + sha256 = "028kc3yfi29qjxs2nyr7dbrr2rcrr8lwpvbxvrq3g8bcwamc4jz4"; + }; + + # src = ../../../uax-15; + +in depot.nix.buildLisp.library { + name = "uax-15"; + + deps = with depot.third_party.lisp; [ + split-sequence + cl-ppcre + (bundled "asdf") + ]; + + srcs = [ + "${src}/uax-15.asd" + "${src}/src/package.lisp" + "${src}/src/utilities.lisp" + "${src}/src/trivial-utf-16.lisp" + (runCommand "precomputed-tables.lisp" {} '' + substitute ${src}/src/precomputed-tables.lisp precomputed-tables.lisp \ + --replace "(asdf:system-source-directory (asdf:find-system 'uax-15 nil))" \ + '"${src}/"' + + sed -i precomputed-tables.lisp \ + -e '17i(defvar *canonical-decomp-map*)' \ + -e '17i(defvar *compatible-decomp-map*)' \ + -e '17i(defvar *canonical-combining-class*)' + + cp precomputed-tables.lisp $out + '') + "${src}/src/normalize-backend.lisp" + "${src}/src/uax-15.lisp" + ]; +} diff --git a/third_party/lisp/unix-opts.nix b/third_party/lisp/unix-opts.nix new file mode 100644 index 000000000000..389de25eff4f --- /dev/null +++ b/third_party/lisp/unix-opts.nix @@ -0,0 +1,17 @@ +# unix-opts is a portable command line argument parser +{ depot, pkgs, ...}: + +let + src = pkgs.fetchFromGitHub { + owner = "libre-man"; + repo = "unix-opts"; + rev = "b805050b074bd860edd18cfc8776fdec666ec36e"; + sha256 = "0j93dkc9f77wz1zfspm7q1scx6wwbm6jhk8vl2rm6bfd0n8scxla"; + }; +in depot.nix.buildLisp.library { + name = "unix-opts"; + + srcs = [ + "${src}/unix-opts.lisp" + ]; +} diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix new file mode 100644 index 000000000000..dc4281c795c0 --- /dev/null +++ b/third_party/lisp/usocket.nix @@ -0,0 +1,51 @@ +# Usocket is a portable socket library +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + + src = pkgs.fetchFromGitHub { + owner = "usocket"; + repo = "usocket"; + rev = "fdf4fd1e0051ce83340ccfbbc8a43a462bb19cf2"; + sha256 = "0x746wr2324l6bn7skqzgkzcbj5kd0zp2ck0c8rldrw0rzabg826"; + }; +in buildLisp.library { + name = "usocket"; + deps = with depot.third_party.lisp; [ + (buildLisp.bundled "asdf") + { + ecl = buildLisp.bundled "sb-bsd-sockets"; + sbcl = buildLisp.bundled "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" + ] ++ [ + { sbcl = "${src}/backend/sbcl.lisp"; } + + # ECL actually has two files, it supports the SBCL backend, + # but usocket also has some ECL specific code + { ecl = "${src}/backend/sbcl.lisp"; } + { ecl = "${src}/backend/ecl.lisp"; } + + # Same for CCL + { ccl = "${src}/backend/openmcl.lisp"; } + { ccl = "${src}/backend/clozure.lisp"; } + ]); +} |