diff options
Diffstat (limited to 'third_party/lisp')
201 files changed, 8351 insertions, 12643 deletions
diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS index 3f06a5376d..6536baf505 100644 --- a/third_party/lisp/OWNERS +++ b/third_party/lisp/OWNERS @@ -1,5 +1,2 @@ -# -*- mode: yaml; -*- -inherited: true -owners: - - eta - - glittershark +eta +aspen diff --git a/third_party/lisp/alexandria.nix b/third_party/lisp/alexandria.nix new file mode 100644 index 0000000000..b522e2d142 --- /dev/null +++ b/third_party/lisp/alexandria.nix @@ -0,0 +1,28 @@ +# Alexandria is one of the foundational Common Lisp libraries that +# pretty much everything depends on. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.alexandria; +in depot.nix.buildLisp.library { + name = "alexandria"; + + srcs = map (f: src + ("/alexandria-1/" + f)) [ + "package.lisp" + "definitions.lisp" + "binding.lisp" + "strings.lisp" + "conditions.lisp" + "symbols.lisp" + "macros.lisp" + "functions.lisp" + "io.lisp" + "hash-tables.lisp" + "control-flow.lisp" + "lists.lisp" + "types.lisp" + "arrays.lisp" + "sequences.lisp" + "numbers.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/alexandria/.boring b/third_party/lisp/alexandria/.boring deleted file mode 100644 index dfa9e6dd7b..0000000000 --- a/third_party/lisp/alexandria/.boring +++ /dev/null @@ -1,13 +0,0 @@ -# Boring file regexps: -~$ -^_darcs -^\{arch\} -^.arch-ids -\# -\.dfsl$ -\.ppcf$ -\.fasl$ -\.x86f$ -\.fas$ -\.lib$ -^public_html diff --git a/third_party/lisp/alexandria/.gitignore b/third_party/lisp/alexandria/.gitignore deleted file mode 100644 index e832e94718..0000000000 --- a/third_party/lisp/alexandria/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -*.fasl -*~ -\#* -*.patch diff --git a/third_party/lisp/alexandria/AUTHORS b/third_party/lisp/alexandria/AUTHORS deleted file mode 100644 index b550ea5032..0000000000 --- a/third_party/lisp/alexandria/AUTHORS +++ /dev/null @@ -1,9 +0,0 @@ - -ACTA EST FABULA PLAUDITE - -Nikodemus Siivola -Attila Lendvai -Marco Baringer -Robert Strandh -Luis Oliveira -Tobias C. Rittweiler \ No newline at end of file diff --git a/third_party/lisp/alexandria/LICENCE b/third_party/lisp/alexandria/LICENCE deleted file mode 100644 index b5140fbb24..0000000000 --- a/third_party/lisp/alexandria/LICENCE +++ /dev/null @@ -1,37 +0,0 @@ -Alexandria software and associated documentation are in the public -domain: - - Authors dedicate this work to public domain, for the benefit of the - public at large and to the detriment of the authors' heirs and - successors. Authors intends this dedication to be an overt act of - relinquishment in perpetuity of all present and future rights under - copyright law, whether vested or contingent, in the work. Authors - understands that such relinquishment of all rights includes the - relinquishment of all rights to enforce (by lawsuit or otherwise) - those copyrights in the work. - - Authors recognize that, once placed in the public domain, the work - may be freely reproduced, distributed, transmitted, used, modified, - built upon, or otherwise exploited by anyone for any purpose, - commercial or non-commercial, and in any way, including by methods - that have not yet been invented or conceived. - -In those legislations where public domain dedications are not -recognized or possible, Alexandria is distributed under the following -terms and conditions: - - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation files - (the "Software"), to deal in the Software without restriction, - including without limitation the rights to use, copy, modify, merge, - publish, distribute, sublicense, and/or sell copies of the Software, - and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/third_party/lisp/alexandria/README b/third_party/lisp/alexandria/README deleted file mode 100644 index a5dae9ed1a..0000000000 --- a/third_party/lisp/alexandria/README +++ /dev/null @@ -1,52 +0,0 @@ -Alexandria is a collection of portable public domain utilities that -meet the following constraints: - - * Utilities, not extensions: Alexandria will not contain conceptual - extensions to Common Lisp, instead limiting itself to tools and - utilities that fit well within the framework of standard ANSI - Common Lisp. Test-frameworks, system definitions, logging - facilities, serialization layers, etc. are all outside the scope of - Alexandria as a library, though well within the scope of Alexandria - as a project. - - * Conservative: Alexandria limits itself to what project members - consider conservative utilities. Alexandria does not and will not - include anaphoric constructs, loop-like binding macros, etc. - - * Portable: Alexandria limits itself to portable parts of Common - Lisp. Even apparently conservative and useful functions remain - outside the scope of Alexandria if they cannot be implemented - portably. Portability is here defined as portable within a - conforming implementation: implementation bugs are not considered - portability issues. - -Homepage: - - http://common-lisp.net/project/alexandria/ - -Mailing lists: - - http://lists.common-lisp.net/mailman/listinfo/alexandria-devel - http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs - -Repository: - - git://gitlab.common-lisp.net/alexandria/alexandria.git - -Documentation: - - http://common-lisp.net/project/alexandria/draft/alexandria.html - - (To build docs locally: cd doc && make html pdf info) - -Patches: - - Patches are always welcome! Please send them to the mailing list as - attachments, generated by "git format-patch -1". - - Patches should include a commit message that explains what's being - done and /why/, and when fixing a bug or adding a feature you should - also include a test-case. - - Be advised though that right now new features are unlikely to be - accepted until 1.0 is officially out of the door. diff --git a/third_party/lisp/alexandria/alexandria-tests.asd b/third_party/lisp/alexandria/alexandria-tests.asd deleted file mode 100644 index 445c18cf7f..0000000000 --- a/third_party/lisp/alexandria/alexandria-tests.asd +++ /dev/null @@ -1,11 +0,0 @@ -(defsystem "alexandria-tests" - :licence "Public Domain / 0-clause MIT" - :description "Tests for Alexandria, which is a collection of portable public domain utilities." - :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others." - :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt) - :components ((:file "tests")) - :perform (test-op (o c) - (flet ((run-tests (&rest args) - (apply (intern (string '#:run-tests) '#:alexandria-tests) args))) - (run-tests :compiled nil) - (run-tests :compiled t)))) diff --git a/third_party/lisp/alexandria/alexandria.asd b/third_party/lisp/alexandria/alexandria.asd deleted file mode 100644 index db10e4f537..0000000000 --- a/third_party/lisp/alexandria/alexandria.asd +++ /dev/null @@ -1,62 +0,0 @@ -(defsystem "alexandria" - :version "1.0.0" - :licence "Public Domain / 0-clause MIT" - :description "Alexandria is a collection of portable public domain utilities." - :author "Nikodemus Siivola and others." - :long-description - "Alexandria is a project and a library. - -As a project Alexandria's goal is to reduce duplication of effort and improve -portability of Common Lisp code according to its own idiosyncratic and rather -conservative aesthetic. - -As a library Alexandria is one of the means by which the project strives for -its goals. - -Alexandria is a collection of portable public domain utilities that meet -the following constraints: - - * Utilities, not extensions: Alexandria will not contain conceptual - extensions to Common Lisp, instead limiting itself to tools and utilities - that fit well within the framework of standard ANSI Common Lisp. - Test-frameworks, system definitions, logging facilities, serialization - layers, etc. are all outside the scope of Alexandria as a library, though - well within the scope of Alexandria as a project. - - * Conservative: Alexandria limits itself to what project members consider - conservative utilities. Alexandria does not and will not include anaphoric - constructs, loop-like binding macros, etc. - Also, its exported symbols are being imported by many other packages - already, so each new export carries the danger of causing conflicts. - - * Portable: Alexandria limits itself to portable parts of Common Lisp. Even - apparently conservative and useful functions remain outside the scope of - Alexandria if they cannot be implemented portably. Portability is here - defined as portable within a conforming implementation: implementation bugs - are not considered portability issues. - - * Team player: Alexandria will not (initially, at least) subsume or provide - functionality for which good-quality special-purpose packages exist, like - split-sequence. Instead, third party packages such as that may be - \"blessed\"." - :components - ((:static-file "LICENCE") - (:static-file "tests.lisp") - (:file "package") - (:file "definitions" :depends-on ("package")) - (:file "binding" :depends-on ("package")) - (:file "strings" :depends-on ("package")) - (:file "conditions" :depends-on ("package")) - (:file "io" :depends-on ("package" "macros" "lists" "types")) - (:file "macros" :depends-on ("package" "strings" "symbols")) - (:file "hash-tables" :depends-on ("package" "macros")) - (:file "control-flow" :depends-on ("package" "definitions" "macros")) - (:file "symbols" :depends-on ("package")) - (:file "functions" :depends-on ("package" "symbols" "macros")) - (:file "lists" :depends-on ("package" "functions")) - (:file "types" :depends-on ("package" "symbols" "lists")) - (:file "arrays" :depends-on ("package" "types")) - (:file "sequences" :depends-on ("package" "lists" "types")) - (:file "numbers" :depends-on ("package" "sequences")) - (:file "features" :depends-on ("package" "control-flow"))) - :in-order-to ((test-op (test-op "alexandria-tests")))) diff --git a/third_party/lisp/alexandria/arrays.lisp b/third_party/lisp/alexandria/arrays.lisp deleted file mode 100644 index 76c18791ad..0000000000 --- a/third_party/lisp/alexandria/arrays.lisp +++ /dev/null @@ -1,18 +0,0 @@ -(in-package :alexandria) - -(defun copy-array (array &key (element-type (array-element-type array)) - (fill-pointer (and (array-has-fill-pointer-p array) - (fill-pointer array))) - (adjustable (adjustable-array-p array))) - "Returns an undisplaced copy of ARRAY, with same fill-pointer and -adjustability (if any) as the original, unless overridden by the keyword -arguments." - (let* ((dimensions (array-dimensions array)) - (new-array (make-array dimensions - :element-type element-type - :adjustable adjustable - :fill-pointer fill-pointer))) - (dotimes (i (array-total-size array)) - (setf (row-major-aref new-array i) - (row-major-aref array i))) - new-array)) diff --git a/third_party/lisp/alexandria/binding.lisp b/third_party/lisp/alexandria/binding.lisp deleted file mode 100644 index 37a3d52fb9..0000000000 --- a/third_party/lisp/alexandria/binding.lisp +++ /dev/null @@ -1,90 +0,0 @@ -(in-package :alexandria) - -(defmacro if-let (bindings &body (then-form &optional else-form)) - "Creates new variable bindings, and conditionally executes either -THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL. - -BINDINGS must be either single binding of the form: - - (variable initial-form) - -or a list of bindings of the form: - - ((variable-1 initial-form-1) - (variable-2 initial-form-2) - ... - (variable-n initial-form-n)) - -All initial-forms are executed sequentially in the specified order. Then all -the variables are bound to the corresponding values. - -If all variables were bound to true values, the THEN-FORM is executed with the -bindings in effect, otherwise the ELSE-FORM is executed with the bindings in -effect." - (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) - (list bindings) - bindings)) - (variables (mapcar #'car binding-list))) - `(let ,binding-list - (if (and ,@variables) - ,then-form - ,else-form)))) - -(defmacro when-let (bindings &body forms) - "Creates new variable bindings, and conditionally executes FORMS. - -BINDINGS must be either single binding of the form: - - (variable initial-form) - -or a list of bindings of the form: - - ((variable-1 initial-form-1) - (variable-2 initial-form-2) - ... - (variable-n initial-form-n)) - -All initial-forms are executed sequentially in the specified order. Then all -the variables are bound to the corresponding values. - -If all variables were bound to true values, then FORMS are executed as an -implicit PROGN." - (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) - (list bindings) - bindings)) - (variables (mapcar #'car binding-list))) - `(let ,binding-list - (when (and ,@variables) - ,@forms)))) - -(defmacro when-let* (bindings &body body) - "Creates new variable bindings, and conditionally executes BODY. - -BINDINGS must be either single binding of the form: - - (variable initial-form) - -or a list of bindings of the form: - - ((variable-1 initial-form-1) - (variable-2 initial-form-2) - ... - (variable-n initial-form-n)) - -Each INITIAL-FORM is executed in turn, and the variable bound to the -corresponding value. INITIAL-FORM expressions can refer to variables -previously bound by the WHEN-LET*. - -Execution of WHEN-LET* stops immediately if any INITIAL-FORM evaluates to NIL. -If all INITIAL-FORMs evaluate to true, then BODY is executed as an implicit -PROGN." - (let ((binding-list (if (and (consp bindings) (symbolp (car bindings))) - (list bindings) - bindings))) - (labels ((bind (bindings body) - (if bindings - `(let (,(car bindings)) - (when ,(caar bindings) - ,(bind (cdr bindings) body))) - `(progn ,@body)))) - (bind binding-list body)))) diff --git a/third_party/lisp/alexandria/conditions.lisp b/third_party/lisp/alexandria/conditions.lisp deleted file mode 100644 index ac471cca7e..0000000000 --- a/third_party/lisp/alexandria/conditions.lisp +++ /dev/null @@ -1,91 +0,0 @@ -(in-package :alexandria) - -(defun required-argument (&optional name) - "Signals an error for a missing argument of NAME. Intended for -use as an initialization form for structure and class-slots, and -a default value for required keyword arguments." - (error "Required argument ~@[~S ~]missing." name)) - -(define-condition simple-style-warning (simple-warning style-warning) - ()) - -(defun simple-style-warning (message &rest args) - (warn 'simple-style-warning :format-control message :format-arguments args)) - -;; We don't specify a :report for simple-reader-error to let the -;; underlying implementation report the line and column position for -;; us. Unfortunately this way the message from simple-error is not -;; displayed, unless there's special support for that in the -;; implementation. But even then it's still inspectable from the -;; debugger... -(define-condition simple-reader-error - #-sbcl(simple-error reader-error) - #+sbcl(sb-int:simple-reader-error) - ()) - -(defun simple-reader-error (stream message &rest args) - (error 'simple-reader-error - :stream stream - :format-control message - :format-arguments args)) - -(define-condition simple-parse-error (simple-error parse-error) - ()) - -(defun simple-parse-error (message &rest args) - (error 'simple-parse-error - :format-control message - :format-arguments args)) - -(define-condition simple-program-error (simple-error program-error) - ()) - -(defun simple-program-error (message &rest args) - (error 'simple-program-error - :format-control message - :format-arguments args)) - -(defmacro ignore-some-conditions ((&rest conditions) &body body) - "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS -list determines which specific conditions are to be ignored." - `(handler-case - (progn ,@body) - ,@(loop for condition in conditions collect - `(,condition (c) (values nil c))))) - -(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses) - "Like CL:UNWIND-PROTECT, but you can specify the circumstances that -the cleanup CLAUSES are run. - - clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)* - -Clauses can be given in any order, and more than one clause can be -given for each circumstance. The clauses whose denoted circumstance -occured, are executed in the order the clauses appear. - -ABORT-FLAG is the name of a variable that will be bound to T in -CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL -otherwise. - -Examples: - - (unwind-protect-case () - (protected-form) - (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\")) - (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\")) - (:always (format t \"This is evaluated in either case.~%\"))) - - (unwind-protect-case (aborted-p) - (protected-form) - (:always (perform-cleanup-if aborted-p))) -" - (check-type abort-flag (or null symbol)) - (let ((gflag (gensym "FLAG+"))) - `(let ((,gflag t)) - (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil)) - (let ,(and abort-flag `((,abort-flag ,gflag))) - ,@(loop for (cleanup-kind . forms) in clauses - collect (ecase cleanup-kind - (:normal `(when (not ,gflag) ,@forms)) - (:abort `(when ,gflag ,@forms)) - (:always `(progn ,@forms))))))))) \ No newline at end of file diff --git a/third_party/lisp/alexandria/control-flow.lisp b/third_party/lisp/alexandria/control-flow.lisp deleted file mode 100644 index dd00df3e16..0000000000 --- a/third_party/lisp/alexandria/control-flow.lisp +++ /dev/null @@ -1,106 +0,0 @@ -(in-package :alexandria) - -(defun extract-function-name (spec) - "Useful for macros that want to mimic the functional interface for functions -like #'eq and 'eq." - (if (and (consp spec) - (member (first spec) '(quote function))) - (second spec) - spec)) - -(defun generate-switch-body (whole object clauses test key &optional default) - (with-gensyms (value) - (setf test (extract-function-name test)) - (setf key (extract-function-name key)) - (when (and (consp default) - (member (first default) '(error cerror))) - (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S." - ,value ',test))) - `(let ((,value (,key ,object))) - (cond ,@(mapcar (lambda (clause) - (if (member (first clause) '(t otherwise)) - (progn - (when default - (error "Multiple default clauses or illegal use of a default clause in ~S." - whole)) - (setf default `(progn ,@(rest clause))) - '(())) - (destructuring-bind (key-form &body forms) clause - `((,test ,value ,key-form) - ,@forms)))) - clauses) - (t ,default))))) - -(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity)) - &body clauses) - "Evaluates first matching clause, returning its values, or evaluates and -returns the values of T or OTHERWISE if no keys match." - (generate-switch-body whole object clauses test key)) - -(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity)) - &body clauses) - "Like SWITCH, but signals an error if no key matches." - (generate-switch-body whole object clauses test key '(error))) - -(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity)) - &body clauses) - "Like SWITCH, but signals a continuable error if no key matches." - (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) - -(defmacro whichever (&rest possibilities &environment env) - "Evaluates exactly one of POSSIBILITIES, chosen at random." - (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities)) - (if (every (lambda (p) (constantp p)) possibilities) - `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities))) - (labels ((expand (possibilities position random-number) - (if (null (cdr possibilities)) - (car possibilities) - (let* ((length (length possibilities)) - (half (truncate length 2)) - (second-half (nthcdr half possibilities)) - (first-half (butlast possibilities (- length half)))) - `(if (< ,random-number ,(+ position half)) - ,(expand first-half position random-number) - ,(expand second-half (+ position half) random-number)))))) - (with-gensyms (random-number) - (let ((length (length possibilities))) - `(let ((,random-number (random ,length))) - ,(expand possibilities 0 random-number))))))) - -(defmacro xor (&rest datums) - "Evaluates its arguments one at a time, from left to right. If more than one -argument evaluates to a true value no further DATUMS are evaluated, and NIL is -returned as both primary and secondary value. If exactly one argument -evaluates to true, its value is returned as the primary value after all the -arguments have been evaluated, and T is returned as the secondary value. If no -arguments evaluate to true NIL is retuned as primary, and T as secondary -value." - (with-gensyms (xor tmp true) - `(let (,tmp ,true) - (block ,xor - ,@(mapcar (lambda (datum) - `(if (setf ,tmp ,datum) - (if ,true - (return-from ,xor (values nil nil)) - (setf ,true ,tmp)))) - datums) - (return-from ,xor (values ,true t)))))) - -(defmacro nth-value-or (nth-value &body forms) - "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one -of the forms is true. It then returns all the values returned by evaluating -that form. If none of the forms return a true nth value, this form returns -NIL." - (once-only (nth-value) - (with-gensyms (values) - `(let ((,values (multiple-value-list ,(first forms)))) - (if (nth ,nth-value ,values) - (values-list ,values) - ,(if (rest forms) - `(nth-value-or ,nth-value ,@(rest forms)) - nil)))))) - -(defmacro multiple-value-prog2 (first-form second-form &body forms) - "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value -all the value returned by SECOND-FORM." - `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms))) diff --git a/third_party/lisp/alexandria/default.nix b/third_party/lisp/alexandria/default.nix deleted file mode 100644 index 2358c898b3..0000000000 --- a/third_party/lisp/alexandria/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -# Alexandria is one of the foundational Common Lisp libraries that -# pretty much everything depends on: -# -# Imported from https://common-lisp.net/project/alexandria/ -{ depot, ... }: - -depot.nix.buildLisp.library { - name = "alexandria"; - srcs = [ - ./package.lisp - ./definitions.lisp - ./binding.lisp - ./strings.lisp - ./conditions.lisp - ./symbols.lisp - ./macros.lisp - ./functions.lisp - ./io.lisp - ./hash-tables.lisp - ./control-flow.lisp - ./lists.lisp - ./types.lisp - ./arrays.lisp - ./sequences.lisp - ./numbers.lisp - ./features.lisp - ]; -} diff --git a/third_party/lisp/alexandria/definitions.lisp b/third_party/lisp/alexandria/definitions.lisp deleted file mode 100644 index 863e1f6962..0000000000 --- a/third_party/lisp/alexandria/definitions.lisp +++ /dev/null @@ -1,37 +0,0 @@ -(in-package :alexandria) - -(defun %reevaluate-constant (name value test) - (if (not (boundp name)) - value - (let ((old (symbol-value name)) - (new value)) - (if (not (constantp name)) - (prog1 new - (cerror "Try to redefine the variable as a constant." - "~@<~S is an already bound non-constant variable ~ - whose value is ~S.~:@>" name old)) - (if (funcall test old new) - old - (restart-case - (error "~@<~S is an already defined constant whose value ~ - ~S is not equal to the provided initial value ~S ~ - under ~S.~:@>" name old new test) - (ignore () - :report "Retain the current value." - old) - (continue () - :report "Try to redefine the constant." - new))))))) - -(defmacro define-constant (name initial-value &key (test ''eql) documentation) - "Ensures that the global variable named by NAME is a constant with a value -that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a -/function designator/ that defaults to EQL. If DOCUMENTATION is given, it -becomes the documentation string of the constant. - -Signals an error if NAME is already a bound non-constant variable. - -Signals an error if NAME is already a constant variable whose value is not -equal under TEST to result of evaluating INITIAL-VALUE." - `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) - ,@(when documentation `(,documentation)))) diff --git a/third_party/lisp/alexandria/doc/.gitignore b/third_party/lisp/alexandria/doc/.gitignore deleted file mode 100644 index f22577b3ac..0000000000 --- a/third_party/lisp/alexandria/doc/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -alexandria -include - diff --git a/third_party/lisp/alexandria/doc/Makefile b/third_party/lisp/alexandria/doc/Makefile deleted file mode 100644 index 85eb818220..0000000000 --- a/third_party/lisp/alexandria/doc/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -.PHONY: clean html pdf include clean-include clean-crap info doc - -doc: pdf html info clean-crap - -clean-include: - rm -rf include - -clean-crap: - rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr - -clean: clean-include - rm -f *.pdf *.html *.info - -include: - sbcl --no-userinit --eval '(require :asdf)' \ - --eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \ - --load docstrings.lisp \ - --eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \ - --eval '(quit)' - -pdf: include - texi2pdf alexandria.texinfo - -html: include - makeinfo --html --no-split alexandria.texinfo - -info: include - makeinfo alexandria.texinfo diff --git a/third_party/lisp/alexandria/doc/alexandria.texinfo b/third_party/lisp/alexandria/doc/alexandria.texinfo deleted file mode 100644 index 89b03ac349..0000000000 --- a/third_party/lisp/alexandria/doc/alexandria.texinfo +++ /dev/null @@ -1,277 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename alexandria.info -@settitle Alexandria Manual -@c %**end of header - -@settitle Alexandria Manual -- draft version - -@c for install-info -@dircategory Software development -@direntry -* alexandria: Common Lisp utilities. -@end direntry - -@copying -Alexandria software and associated documentation are in the public -domain: - -@quotation - Authors dedicate this work to public domain, for the benefit of the - public at large and to the detriment of the authors' heirs and - successors. Authors intends this dedication to be an overt act of - relinquishment in perpetuity of all present and future rights under - copyright law, whether vested or contingent, in the work. Authors - understands that such relinquishment of all rights includes the - relinquishment of all rights to enforce (by lawsuit or otherwise) - those copyrights in the work. - - Authors recognize that, once placed in the public domain, the work - may be freely reproduced, distributed, transmitted, used, modified, - built upon, or otherwise exploited by anyone for any purpose, - commercial or non-commercial, and in any way, including by methods - that have not yet been invented or conceived. -@end quotation - -In those legislations where public domain dedications are not -recognized or possible, Alexandria is distributed under the following -terms and conditions: - -@quotation - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation files - (the "Software"), to deal in the Software without restriction, - including without limitation the rights to use, copy, modify, merge, - publish, distribute, sublicense, and/or sell copies of the Software, - and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -@end quotation -@end copying - -@titlepage - -@title Alexandria Manual -@subtitle draft version - -@c The following two commands start the copyright page. -@page -@vskip 0pt plus 1filll -@insertcopying - -@end titlepage - -@contents - -@ifnottex - -@include include/ifnottex.texinfo - -@node Top -@comment node-name, next, previous, up -@top Alexandria - -@insertcopying - -@menu -* Hash Tables:: -* Data and Control Flow:: -* Conses:: -* Sequences:: -* IO:: -* Macro Writing:: -* Symbols:: -* Arrays:: -* Types:: -* Numbers:: -@end menu - -@end ifnottex - -@node Hash Tables -@comment node-name, next, previous, up -@chapter Hash Tables - -@include include/macro-alexandria-ensure-gethash.texinfo -@include include/fun-alexandria-copy-hash-table.texinfo -@include include/fun-alexandria-maphash-keys.texinfo -@include include/fun-alexandria-maphash-values.texinfo -@include include/fun-alexandria-hash-table-keys.texinfo -@include include/fun-alexandria-hash-table-values.texinfo -@include include/fun-alexandria-hash-table-alist.texinfo -@include include/fun-alexandria-hash-table-plist.texinfo -@include include/fun-alexandria-alist-hash-table.texinfo -@include include/fun-alexandria-plist-hash-table.texinfo - -@node Data and Control Flow -@comment node-name, next, previous, up -@chapter Data and Control Flow - -@include include/macro-alexandria-define-constant.texinfo -@include include/macro-alexandria-destructuring-case.texinfo -@include include/macro-alexandria-ensure-functionf.texinfo -@include include/macro-alexandria-multiple-value-prog2.texinfo -@include include/macro-alexandria-named-lambda.texinfo -@include include/macro-alexandria-nth-value-or.texinfo -@include include/macro-alexandria-if-let.texinfo -@include include/macro-alexandria-when-let.texinfo -@include include/macro-alexandria-when-let-star.texinfo -@include include/macro-alexandria-switch.texinfo -@include include/macro-alexandria-cswitch.texinfo -@include include/macro-alexandria-eswitch.texinfo -@include include/macro-alexandria-whichever.texinfo -@include include/macro-alexandria-xor.texinfo - -@include include/fun-alexandria-disjoin.texinfo -@include include/fun-alexandria-conjoin.texinfo -@include include/fun-alexandria-compose.texinfo -@include include/fun-alexandria-ensure-function.texinfo -@include include/fun-alexandria-multiple-value-compose.texinfo -@include include/fun-alexandria-curry.texinfo -@include include/fun-alexandria-rcurry.texinfo - -@node Conses -@comment node-name, next, previous, up -@chapter Conses - -@include include/type-alexandria-proper-list.texinfo -@include include/type-alexandria-circular-list.texinfo - -@include include/macro-alexandria-appendf.texinfo -@include include/macro-alexandria-nconcf.texinfo -@include include/macro-alexandria-remove-from-plistf.texinfo -@include include/macro-alexandria-delete-from-plistf.texinfo -@include include/macro-alexandria-reversef.texinfo -@include include/macro-alexandria-nreversef.texinfo -@include include/macro-alexandria-unionf.texinfo -@include include/macro-alexandria-nunionf.texinfo - -@include include/macro-alexandria-doplist.texinfo - -@include include/fun-alexandria-circular-list-p.texinfo -@include include/fun-alexandria-circular-tree-p.texinfo -@include include/fun-alexandria-proper-list-p.texinfo - -@include include/fun-alexandria-alist-plist.texinfo -@include include/fun-alexandria-plist-alist.texinfo -@include include/fun-alexandria-circular-list.texinfo -@include include/fun-alexandria-make-circular-list.texinfo -@include include/fun-alexandria-ensure-car.texinfo -@include include/fun-alexandria-ensure-cons.texinfo -@include include/fun-alexandria-ensure-list.texinfo -@include include/fun-alexandria-flatten.texinfo -@include include/fun-alexandria-lastcar.texinfo -@include include/fun-alexandria-setf-lastcar.texinfo -@include include/fun-alexandria-proper-list-length.texinfo -@include include/fun-alexandria-mappend.texinfo -@include include/fun-alexandria-map-product.texinfo -@include include/fun-alexandria-remove-from-plist.texinfo -@include include/fun-alexandria-delete-from-plist.texinfo -@include include/fun-alexandria-set-equal.texinfo -@include include/fun-alexandria-setp.texinfo - -@node Sequences -@comment node-name, next, previous, up -@chapter Sequences - -@include include/type-alexandria-proper-sequence.texinfo - -@include include/macro-alexandria-deletef.texinfo -@include include/macro-alexandria-removef.texinfo - -@include include/fun-alexandria-rotate.texinfo -@include include/fun-alexandria-shuffle.texinfo -@include include/fun-alexandria-random-elt.texinfo -@include include/fun-alexandria-emptyp.texinfo -@include include/fun-alexandria-sequence-of-length-p.texinfo -@include include/fun-alexandria-length-equals.texinfo -@include include/fun-alexandria-copy-sequence.texinfo -@include include/fun-alexandria-first-elt.texinfo -@include include/fun-alexandria-setf-first-elt.texinfo -@include include/fun-alexandria-last-elt.texinfo -@include include/fun-alexandria-setf-last-elt.texinfo -@include include/fun-alexandria-starts-with.texinfo -@include include/fun-alexandria-starts-with-subseq.texinfo -@include include/fun-alexandria-ends-with.texinfo -@include include/fun-alexandria-ends-with-subseq.texinfo -@include include/fun-alexandria-map-combinations.texinfo -@include include/fun-alexandria-map-derangements.texinfo -@include include/fun-alexandria-map-permutations.texinfo - -@node IO -@comment node-name, next, previous, up -@chapter IO - -@include include/fun-alexandria-read-stream-content-into-string.texinfo -@include include/fun-alexandria-read-file-into-string.texinfo -@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo -@include include/fun-alexandria-read-file-into-byte-vector.texinfo - -@node Macro Writing -@comment node-name, next, previous, up -@chapter Macro Writing - -@include include/macro-alexandria-once-only.texinfo -@include include/macro-alexandria-with-gensyms.texinfo -@include include/macro-alexandria-with-unique-names.texinfo -@include include/fun-alexandria-featurep.texinfo -@include include/fun-alexandria-parse-body.texinfo -@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo - -@node Symbols -@comment node-name, next, previous, up -@chapter Symbols - -@include include/fun-alexandria-ensure-symbol.texinfo -@include include/fun-alexandria-format-symbol.texinfo -@include include/fun-alexandria-make-keyword.texinfo -@include include/fun-alexandria-make-gensym.texinfo -@include include/fun-alexandria-make-gensym-list.texinfo -@include include/fun-alexandria-symbolicate.texinfo - -@node Arrays -@comment node-name, next, previous, up -@chapter Arrays - -@include include/type-alexandria-array-index.texinfo -@include include/type-alexandria-array-length.texinfo -@include include/fun-alexandria-copy-array.texinfo - -@node Types -@comment node-name, next, previous, up -@chapter Types - -@include include/type-alexandria-string-designator.texinfo -@include include/macro-alexandria-coercef.texinfo -@include include/fun-alexandria-of-type.texinfo -@include include/fun-alexandria-type-equals.texinfo - -@node Numbers -@comment node-name, next, previous, up -@chapter Numbers - -@include include/macro-alexandria-maxf.texinfo -@include include/macro-alexandria-minf.texinfo - -@include include/fun-alexandria-binomial-coefficient.texinfo -@include include/fun-alexandria-count-permutations.texinfo -@include include/fun-alexandria-clamp.texinfo -@include include/fun-alexandria-lerp.texinfo -@include include/fun-alexandria-factorial.texinfo -@include include/fun-alexandria-subfactorial.texinfo -@include include/fun-alexandria-gaussian-random.texinfo -@include include/fun-alexandria-iota.texinfo -@include include/fun-alexandria-map-iota.texinfo -@include include/fun-alexandria-mean.texinfo -@include include/fun-alexandria-median.texinfo -@include include/fun-alexandria-variance.texinfo -@include include/fun-alexandria-standard-deviation.texinfo - -@bye diff --git a/third_party/lisp/alexandria/doc/docstrings.lisp b/third_party/lisp/alexandria/doc/docstrings.lisp deleted file mode 100644 index 51dda07d09..0000000000 --- a/third_party/lisp/alexandria/doc/docstrings.lisp +++ /dev/null @@ -1,881 +0,0 @@ -;;; -*- lisp -*- - -;;;; A docstring extractor for the sbcl manual. Creates -;;;; @include-ready documentation from the docstrings of exported -;;;; symbols of specified packages. - -;;;; This software is part of the SBCL software system. SBCL is in the -;;;; public domain and is provided with absolutely no warranty. See -;;;; the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled -;;;; by Nikodemus Siivola. - -;;;; TODO -;;;; * Verbatim text -;;;; * Quotations -;;;; * Method documentation untested -;;;; * Method sorting, somehow -;;;; * Index for macros & constants? -;;;; * This is getting complicated enough that tests would be good -;;;; * Nesting (currently only nested itemizations work) -;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also -;;;; easily generated) - -;;;; FIXME: The description below is no longer complete. This -;;;; should possibly be turned into a contrib with proper documentation. - -;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): -;;;; -;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in -;;;; the argument list of the defun / defmacro. -;;;; -;;;; Lines starting with * or - that are followed by intented lines -;;;; are marked up with @itemize. -;;;; -;;;; Lines containing only a SYMBOL that are followed by indented -;;;; lines are marked up as @table @code, with the SYMBOL as the item. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'sb-introspect)) - -(defpackage :sb-texinfo - (:use :cl :sb-mop) - (:shadow #:documentation) - (:export #:generate-includes #:document-package) - (:documentation - "Tools to generate TexInfo documentation from docstrings.")) - -(in-package :sb-texinfo) - -;;;; various specials and parameters - -(defvar *texinfo-output*) -(defvar *texinfo-variables*) -(defvar *documentation-package*) -(defvar *base-package*) - -(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) - -(defparameter *documentation-types* - '(compiler-macro - function - method-combination - setf - ;;structure ; also handled by `type' - type - variable) - "A list of symbols accepted as second argument of `documentation'") - -(defparameter *character-replacements* - '((#\* . "star") (#\/ . "slash") (#\+ . "plus") - (#\< . "lt") (#\> . "gt") - (#\= . "equals")) - "Characters and their replacement names that `alphanumize' uses. If -the replacements contain any of the chars they're supposed to replace, -you deserve to lose.") - -(defparameter *characters-to-drop* '(#\\ #\` #\') - "Characters that should be removed by `alphanumize'.") - -(defparameter *texinfo-escaped-chars* "@{}" - "Characters that must be escaped with #\@ for Texinfo.") - -(defparameter *itemize-start-characters* '(#\* #\-) - "Characters that might start an itemization in docstrings when - at the start of a line.") - -(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'" - "List of characters that make up symbols in a docstring.") - -(defparameter *symbol-delimiters* " ,.!?;") - -(defparameter *ordered-documentation-kinds* - '(package type structure condition class macro)) - -;;;; utilities - -(defun flatten (list) - (cond ((null list) - nil) - ((consp (car list)) - (nconc (flatten (car list)) (flatten (cdr list)))) - ((null (cdr list)) - (cons (car list) nil)) - (t - (cons (car list) (flatten (cdr list)))))) - -(defun whitespacep (char) - (find char #(#\tab #\space #\page))) - -(defun setf-name-p (name) - (or (symbolp name) - (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) - -(defgeneric specializer-name (specializer)) - -(defmethod specializer-name ((specializer eql-specializer)) - (list 'eql (eql-specializer-object specializer))) - -(defmethod specializer-name ((specializer class)) - (class-name specializer)) - -(defun ensure-class-precedence-list (class) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (class-precedence-list class)) - -(defun specialized-lambda-list (method) - ;; courtecy of AMOP p. 61 - (let* ((specializers (method-specializers method)) - (lambda-list (method-lambda-list method)) - (n-required (length specializers))) - (append (mapcar (lambda (arg specializer) - (if (eq specializer (find-class 't)) - arg - `(,arg ,(specializer-name specializer)))) - (subseq lambda-list 0 n-required) - specializers) - (subseq lambda-list n-required)))) - -(defun string-lines (string) - "Lines in STRING as a vector." - (coerce (with-input-from-string (s string) - (loop for line = (read-line s nil nil) - while line collect line)) - 'vector)) - -(defun indentation (line) - "Position of first non-SPACE character in LINE." - (position-if-not (lambda (c) (char= c #\Space)) line)) - -(defun docstring (x doc-type) - (cl:documentation x doc-type)) - -(defun flatten-to-string (list) - (format nil "~{~A~^-~}" (flatten list))) - -(defun alphanumize (original) - "Construct a string without characters like *`' that will f-star-ck -up filename handling. See `*character-replacements*' and -`*characters-to-drop*' for customization." - (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) - (if (listp original) - (flatten-to-string original) - (string original)))) - (chars-to-replace (mapcar #'car *character-replacements*))) - (flet ((replacement-delimiter (index) - (cond ((or (< index 0) (>= index (length name))) "") - ((alphanumericp (char name index)) "-") - (t "")))) - (loop for index = (position-if #'(lambda (x) (member x chars-to-replace)) - name) - while index - do (setf name (concatenate 'string (subseq name 0 index) - (replacement-delimiter (1- index)) - (cdr (assoc (aref name index) - *character-replacements*)) - (replacement-delimiter (1+ index)) - (subseq name (1+ index)))))) - name)) - -;;;; generating various names - -(defgeneric name (thing) - (:documentation "Name for a documented thing. Names are either -symbols or lists of symbols.")) - -(defmethod name ((symbol symbol)) - symbol) - -(defmethod name ((cons cons)) - cons) - -(defmethod name ((package package)) - (short-package-name package)) - -(defmethod name ((method method)) - (list - (generic-function-name (method-generic-function method)) - (method-qualifiers method) - (specialized-lambda-list method))) - -;;; Node names for DOCUMENTATION instances - -(defgeneric name-using-kind/name (kind name doc)) - -(defmethod name-using-kind/name (kind (name string) doc) - (declare (ignore kind doc)) - name) - -(defmethod name-using-kind/name (kind (name symbol) doc) - (declare (ignore kind)) - (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) - -(defmethod name-using-kind/name (kind (name list) doc) - (declare (ignore kind)) - (assert (setf-name-p name)) - (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) - -(defmethod name-using-kind/name ((kind (eql 'method)) name doc) - (format nil "~A~{ ~A~} ~A" - (name-using-kind/name nil (first name) doc) - (second name) - (third name))) - -(defun node-name (doc) - "Returns TexInfo node name as a string for a DOCUMENTATION instance." - (let ((kind (get-kind doc))) - (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) - -(defun short-package-name (package) - (unless (eq package *base-package*) - (car (sort (copy-list (cons (package-name package) (package-nicknames package))) - #'< :key #'length)))) - -;;; Definition titles for DOCUMENTATION instances - -(defgeneric title-using-kind/name (kind name doc)) - -(defmethod title-using-kind/name (kind (name string) doc) - (declare (ignore kind doc)) - name) - -(defmethod title-using-kind/name (kind (name symbol) doc) - (declare (ignore kind)) - (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) - -(defmethod title-using-kind/name (kind (name list) doc) - (declare (ignore kind)) - (assert (setf-name-p name)) - (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) - -(defmethod title-using-kind/name ((kind (eql 'method)) name doc) - (format nil "~{~A ~}~A" - (second name) - (title-using-kind/name nil (first name) doc))) - -(defun title-name (doc) - "Returns a string to be used as name of the definition." - (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) - -(defun include-pathname (doc) - (let* ((kind (get-kind doc)) - (name (nstring-downcase - (if (eq 'package kind) - (format nil "package-~A" (alphanumize (get-name doc))) - (format nil "~A-~A-~A" - (case (get-kind doc) - ((function generic-function) "fun") - (structure "struct") - (variable "var") - (otherwise (symbol-name (get-kind doc)))) - (alphanumize (let ((*base-package* nil)) - (short-package-name (get-package doc)))) - (alphanumize (get-name doc))))))) - (make-pathname :name name :type "texinfo"))) - -;;;; documentation class and related methods - -(defclass documentation () - ((name :initarg :name :reader get-name) - (kind :initarg :kind :reader get-kind) - (string :initarg :string :reader get-string) - (children :initarg :children :initform nil :reader get-children) - (package :initform *documentation-package* :reader get-package))) - -(defmethod print-object ((documentation documentation) stream) - (print-unreadable-object (documentation stream :type t) - (princ (list (get-kind documentation) (get-name documentation)) stream))) - -(defgeneric make-documentation (x doc-type string)) - -(defmethod make-documentation ((x package) doc-type string) - (declare (ignore doc-type)) - (make-instance 'documentation - :name (name x) - :kind 'package - :string string)) - -(defmethod make-documentation (x (doc-type (eql 'function)) string) - (declare (ignore doc-type)) - (let* ((fdef (and (fboundp x) (fdefinition x))) - (name x) - (kind (cond ((and (symbolp x) (special-operator-p x)) - 'special-operator) - ((and (symbolp x) (macro-function x)) - 'macro) - ((typep fdef 'generic-function) - (assert (or (symbolp name) (setf-name-p name))) - 'generic-function) - (fdef - (assert (or (symbolp name) (setf-name-p name))) - 'function))) - (children (when (eq kind 'generic-function) - (collect-gf-documentation fdef)))) - (make-instance 'documentation - :name (name x) - :string string - :kind kind - :children children))) - -(defmethod make-documentation ((x method) doc-type string) - (declare (ignore doc-type)) - (make-instance 'documentation - :name (name x) - :kind 'method - :string string)) - -(defmethod make-documentation (x (doc-type (eql 'type)) string) - (make-instance 'documentation - :name (name x) - :string string - :kind (etypecase (find-class x nil) - (structure-class 'structure) - (standard-class 'class) - (sb-pcl::condition-class 'condition) - ((or built-in-class null) 'type)))) - -(defmethod make-documentation (x (doc-type (eql 'variable)) string) - (make-instance 'documentation - :name (name x) - :string string - :kind (if (constantp x) - 'constant - 'variable))) - -(defmethod make-documentation (x (doc-type (eql 'setf)) string) - (declare (ignore doc-type)) - (make-instance 'documentation - :name (name x) - :kind 'setf-expander - :string string)) - -(defmethod make-documentation (x doc-type string) - (make-instance 'documentation - :name (name x) - :kind doc-type - :string string)) - -(defun maybe-documentation (x doc-type) - "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if -there is no corresponding docstring." - (let ((docstring (docstring x doc-type))) - (when docstring - (make-documentation x doc-type docstring)))) - -(defun lambda-list (doc) - (case (get-kind doc) - ((package constant variable type structure class condition nil) - nil) - (method - (third (get-name doc))) - (t - ;; KLUDGE: Eugh. - ;; - ;; believe it or not, the above comment was written before CSR - ;; came along and obfuscated this. (2005-07-04) - (when (symbolp (get-name doc)) - (labels ((clean (x &key optional key) - (typecase x - (atom x) - ((cons (member &optional)) - (cons (car x) (clean (cdr x) :optional t))) - ((cons (member &key)) - (cons (car x) (clean (cdr x) :key t))) - ((cons (member &whole &environment)) - ;; Skip these - (clean (cdr x) :optional optional :key key)) - ((cons cons) - (cons - (cond (key (if (consp (caar x)) - (caaar x) - (caar x))) - (optional (caar x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional))) - (cons - (cons - (cond ((or key optional) (car x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional)))))) - (clean (sb-introspect:function-lambda-list (get-name doc)))))))) - -(defun get-string-name (x) - (let ((name (get-name x))) - (cond ((symbolp name) - (symbol-name name)) - ((and (consp name) (eq 'setf (car name))) - (symbol-name (second name))) - ((stringp name) - name) - (t - (error "Don't know which symbol to use for name ~S" name))))) - -(defun documentation< (x y) - (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) - (p2 (position (get-kind y) *ordered-documentation-kinds*))) - (if (or (not (and p1 p2)) (= p1 p2)) - (string< (get-string-name x) (get-string-name y)) - (< p1 p2)))) - -;;;; turning text into texinfo - -(defun escape-for-texinfo (string &optional downcasep) - "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped -with #\@. Optionally downcase the result." - (let ((result (with-output-to-string (s) - (loop for char across string - when (find char *texinfo-escaped-chars*) - do (write-char #\@ s) - do (write-char char s))))) - (if downcasep (nstring-downcase result) result))) - -(defun empty-p (line-number lines) - (and (< -1 line-number (length lines)) - (not (indentation (svref lines line-number))))) - -;;; line markups - -(defvar *not-symbols* '("ANSI" "CLHS")) - -(defun locate-symbols (line) - "Return a list of index pairs of symbol-like parts of LINE." - ;; This would be a good application for a regex ... - (let (result) - (flet ((grab (start end) - (unless (member (subseq line start end) '("ANSI" "CLHS")) - (push (list start end) result)))) - (do ((begin nil) - (maybe-begin t) - (i 0 (1+ i))) - ((= i (length line)) - ;; symbol at end of line - (when (and begin (or (> i (1+ begin)) - (not (member (char line begin) '(#\A #\I))))) - (grab begin i)) - (nreverse result)) - (cond - ((and begin (find (char line i) *symbol-delimiters*)) - ;; symbol end; remember it if it's not "A" or "I" - (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) - (grab begin i)) - (setf begin nil - maybe-begin t)) - ((and begin (not (find (char line i) *symbol-characters*))) - ;; Not a symbol: abort - (setf begin nil)) - ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) - ;; potential symbol begin at this position - (setf begin i - maybe-begin nil)) - ((find (char line i) *symbol-delimiters*) - ;; potential symbol begin after this position - (setf maybe-begin t)) - (t - ;; Not reading a symbol, not at potential start of symbol - (setf maybe-begin nil))))))) - -(defun texinfo-line (line) - "Format symbols in LINE texinfo-style: either as code or as -variables if the symbol in question is contained in symbols -*TEXINFO-VARIABLES*." - (with-output-to-string (result) - (let ((last 0)) - (dolist (symbol/index (locate-symbols line)) - (write-string (subseq line last (first symbol/index)) result) - (let ((symbol-name (apply #'subseq line symbol/index))) - (format result (if (member symbol-name *texinfo-variables* - :test #'string=) - "@var{~A}" - "@code{~A}") - (string-downcase symbol-name))) - (setf last (second symbol/index))) - (write-string (subseq line last) result)))) - -;;; lisp sections - -(defun lisp-section-p (line line-number lines) - "Returns T if the given LINE looks like start of lisp code -- -ie. if it starts with whitespace followed by a paren or -semicolon, and the previous line is empty" - (let ((offset (indentation line))) - (and offset - (plusp offset) - (find (find-if-not #'whitespacep line) "(;") - (empty-p (1- line-number) lines)))) - -(defun collect-lisp-section (lines line-number) - (let ((lisp (loop for index = line-number then (1+ index) - for line = (and (< index (length lines)) (svref lines index)) - while (indentation line) - collect line))) - (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) - -;;; itemized sections - -(defun maybe-itemize-offset (line) - "Return NIL or the indentation offset if LINE looks like it starts -an item in an itemization." - (let* ((offset (indentation line)) - (char (when offset (char line offset)))) - (and offset - (member char *itemize-start-characters* :test #'char=) - (char= #\Space (find-if-not (lambda (c) (char= c char)) - line :start offset)) - offset))) - -(defun collect-maybe-itemized-section (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) - (result nil) - (lines-consumed 0)) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-itemize-offset line) - do (cond - ((not indentation) - ;; empty line -- inserts paragraph. - (push "" result) - (incf lines-consumed)) - ((and offset (> indentation this-offset)) - ;; nested itemization -- handle recursively - ;; FIXME: tables in itemizations go wrong - (multiple-value-bind (sub-lines-consumed sub-itemization) - (collect-maybe-itemized-section lines line-number) - (when sub-lines-consumed - (incf line-number (1- sub-lines-consumed)) ; +1 on next loop - (incf lines-consumed sub-lines-consumed) - (setf result (nconc (nreverse sub-itemization) result))))) - ((and offset (= indentation this-offset)) - ;; start of new item - (push (format nil "@item ~A" - (texinfo-line (subseq line (1+ offset)))) - result) - (incf lines-consumed)) - ((and (not offset) (> indentation this-offset)) - ;; continued item from previous line - (push (texinfo-line line) result) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - ;; a single-line itemization isn't. - (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) - nil))) - -;;; table sections - -(defun tabulation-body-p (offset line-number lines) - (when (< line-number (length lines)) - (let ((offset2 (indentation (svref lines line-number)))) - (and offset2 (< offset offset2))))) - -(defun tabulation-p (offset line-number lines direction) - (let ((step (ecase direction - (:backwards (1- line-number)) - (:forwards (1+ line-number))))) - (when (and (plusp line-number) (< line-number (length lines))) - (and (eql offset (indentation (svref lines line-number))) - (or (when (eq direction :backwards) - (empty-p step lines)) - (tabulation-p offset step lines direction) - (tabulation-body-p offset step lines)))))) - -(defun maybe-table-offset (line-number lines) - "Return NIL or the indentation offset if LINE looks like it starts -an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an -empty line, another tabulation label, or a tabulation body, (3) and -followed another tabulation label or a tabulation body." - (let* ((line (svref lines line-number)) - (offset (indentation line)) - (prev (1- line-number)) - (next (1+ line-number))) - (when (and offset (plusp offset)) - (and (or (empty-p prev lines) - (tabulation-body-p offset prev lines) - (tabulation-p offset prev lines :backwards)) - (or (tabulation-body-p offset next lines) - (tabulation-p offset next lines :forwards)) - offset)))) - -;;; FIXME: This and itemization are very similar: could they share -;;; some code, mayhap? - -(defun collect-maybe-table-section (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-table-offset starting-line lines)) - (result nil) - (lines-consumed 0)) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-table-offset line-number lines) - do (cond - ((not indentation) - ;; empty line -- inserts paragraph. - (push "" result) - (incf lines-consumed)) - ((and offset (= indentation this-offset)) - ;; start of new item, or continuation of previous item - (if (and result (search "@item" (car result) :test #'char=)) - (push (format nil "@itemx ~A" (texinfo-line line)) - result) - (progn - (push "" result) - (push (format nil "@item ~A" (texinfo-line line)) - result))) - (incf lines-consumed)) - ((> indentation this-offset) - ;; continued item from previous line - (push (texinfo-line line) result) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - ;; a single-line table isn't. - (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed - `("" "@table @emph" ,@(reverse result) "@end table" "")) - nil))) - -;;; section markup - -(defmacro with-maybe-section (index &rest forms) - `(multiple-value-bind (count collected) (progn ,@forms) - (when count - (dolist (line collected) - (write-line line *texinfo-output*)) - (incf ,index (1- count))))) - -(defun write-texinfo-string (string &optional lambda-list) - "Try to guess as much formatting for a raw docstring as possible." - (let ((*texinfo-variables* (flatten lambda-list)) - (lines (string-lines (escape-for-texinfo string nil)))) - (loop for line-number from 0 below (length lines) - for line = (svref lines line-number) - do (cond - ((with-maybe-section line-number - (and (lisp-section-p line line-number lines) - (collect-lisp-section lines line-number)))) - ((with-maybe-section line-number - (and (maybe-itemize-offset line) - (collect-maybe-itemized-section lines line-number)))) - ((with-maybe-section line-number - (and (maybe-table-offset line-number lines) - (collect-maybe-table-section lines line-number)))) - (t - (write-line (texinfo-line line) *texinfo-output*)))))) - -;;;; texinfo formatting tools - -(defun hide-superclass-p (class-name super-name) - (let ((super-package (symbol-package super-name))) - (or - ;; KLUDGE: We assume that we don't want to advertise internal - ;; classes in CP-lists, unless the symbol we're documenting is - ;; internal as well. - (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) - (not (eq super-package (symbol-package class-name)))) - ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or - ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them - ;; simply as a matter of convenience. The assumption here is that - ;; the inheritance is incidental unless the name of the condition - ;; begins with SIMPLE-. - (and (member super-name '(simple-error simple-condition)) - (let ((prefix "SIMPLE-")) - (mismatch prefix (string class-name) :end2 (length prefix))) - t ; don't return number from MISMATCH - )))) - -(defun hide-slot-p (symbol slot) - ;; FIXME: There is no pricipal reason to avoid the slot docs fo - ;; structures and conditions, but their DOCUMENTATION T doesn't - ;; currently work with them the way we'd like. - (not (and (typep (find-class symbol nil) 'standard-class) - (docstring slot t)))) - -(defun texinfo-anchor (doc) - (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) - -;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" -(defun texinfo-begin (doc &aux *print-pretty*) - (let ((kind (get-kind doc))) - (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%" - (case kind - ((package constant variable) - "defvr") - ((structure class condition type) - "deftp") - (t - "deffn")) - (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) - (title-name doc) - ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo - ;; interactions,so we escape the ampersand -- amusingly for TeX. - ;; sbcl.texinfo defines macros that expand @&key and friends to &key. - (mapcar (lambda (name) - (if (member name lambda-list-keywords) - (format nil "@~A" name) - name)) - (lambda-list doc))))) - -(defun texinfo-index (doc) - (let ((title (title-name doc))) - (case (get-kind doc) - ((structure type class condition) - (format *texinfo-output* "@tindex ~A~%" title)) - ((variable constant) - (format *texinfo-output* "@vindex ~A~%" title)) - ((compiler-macro function method-combination macro generic-function) - (format *texinfo-output* "@findex ~A~%" title))))) - -(defun texinfo-inferred-body (doc) - (when (member (get-kind doc) '(class structure condition)) - (let ((name (get-name doc))) - ;; class precedence list - (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%" - (remove-if (lambda (class) (hide-superclass-p name class)) - (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) - ;; slots - (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) - (class-direct-slots (find-class name))))) - (when slots - (format *texinfo-output* "Slots:~%@itemize~%") - (dolist (slot slots) - (format *texinfo-output* - "@item ~(@code{~A}~#[~:; --- ~]~ - ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" - (slot-definition-name slot) - (remove - nil - (mapcar - (lambda (name things) - (if things - (list name (length things) things))) - '("initarg" "reader" "writer") - (list - (slot-definition-initargs slot) - (slot-definition-readers slot) - (slot-definition-writers slot))))) - ;; FIXME: Would be neater to handler as children - (write-texinfo-string (docstring slot t))) - (format *texinfo-output* "@end itemize~%~%")))))) - -(defun texinfo-body (doc) - (write-texinfo-string (get-string doc))) - -(defun texinfo-end (doc) - (write-line (case (get-kind doc) - ((package variable constant) "@end defvr") - ((structure type class condition) "@end deftp") - (t "@end deffn")) - *texinfo-output*)) - -(defun write-texinfo (doc) - "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." - (texinfo-anchor doc) - (texinfo-begin doc) - (texinfo-index doc) - (texinfo-inferred-body doc) - (texinfo-body doc) - (texinfo-end doc) - ;; FIXME: Children should be sorted one way or another - (mapc #'write-texinfo (get-children doc))) - -;;;; main logic - -(defun collect-gf-documentation (gf) - "Collects method documentation for the generic function GF" - (loop for method in (generic-function-methods gf) - for doc = (maybe-documentation method t) - when doc - collect doc)) - -(defun collect-name-documentation (name) - (loop for type in *documentation-types* - for doc = (maybe-documentation name type) - when doc - collect doc)) - -(defun collect-symbol-documentation (symbol) - "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of -the form DOC instances. See `*documentation-types*' for the possible -values of doc-type." - (nconc (collect-name-documentation symbol) - (collect-name-documentation (list 'setf symbol)))) - -(defun collect-documentation (package) - "Collects all documentation for all external symbols of the given -package, as well as for the package itself." - (let* ((*documentation-package* (find-package package)) - (docs nil)) - (check-type package package) - (do-external-symbols (symbol package) - (setf docs (nconc (collect-symbol-documentation symbol) docs))) - (let ((doc (maybe-documentation *documentation-package* t))) - (when doc - (push doc docs))) - docs)) - -(defmacro with-texinfo-file (pathname &body forms) - `(with-open-file (*texinfo-output* ,pathname - :direction :output - :if-does-not-exist :create - :if-exists :supersede) - ,@forms)) - -(defun write-ifnottex () - ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to - ;; define them for info as well. - (flet ((macro (name) - (let ((string (string-downcase name))) - (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string)))) - (macro '&allow-other-keys) - (macro '&optional) - (macro '&rest) - (macro '&key) - (macro '&body))) - -(defun generate-includes (directory packages &key (base-package :cl-user)) - "Create files in `directory' containing Texinfo markup of all -docstrings of each exported symbol in `packages'. `directory' is -created if necessary. If you supply a namestring that doesn't end in a -slash, you lose. The generated files are of the form -\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included -via @include statements. Texinfo syntax-significant characters are -escaped in symbol names, but if a docstring contains invalid Texinfo -markup, you lose." - (handler-bind ((warning #'muffle-warning)) - (let ((directory (merge-pathnames (pathname directory))) - (*base-package* (find-package base-package))) - (ensure-directories-exist directory) - (dolist (package packages) - (dolist (doc (collect-documentation (find-package package))) - (with-texinfo-file (merge-pathnames (include-pathname doc) directory) - (write-texinfo doc)))) - (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) - (write-ifnottex)) - directory))) - -(defun document-package (package &optional filename) - "Create a file containing all available documentation for the -exported symbols of `package' in Texinfo format. If `filename' is not -supplied, a file \"<packagename>.texinfo\" is generated. - -The definitions can be referenced using Texinfo statements like -@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo -syntax-significant characters are escaped in symbol names, but if a -docstring contains invalid Texinfo markup, you lose." - (handler-bind ((warning #'muffle-warning)) - (let* ((package (find-package package)) - (filename (or filename (make-pathname - :name (string-downcase (short-package-name package)) - :type "texinfo"))) - (docs (sort (collect-documentation package) #'documentation<))) - (with-texinfo-file filename - (dolist (doc docs) - (write-texinfo doc))) - filename))) diff --git a/third_party/lisp/alexandria/features.lisp b/third_party/lisp/alexandria/features.lisp deleted file mode 100644 index 67348dbba4..0000000000 --- a/third_party/lisp/alexandria/features.lisp +++ /dev/null @@ -1,14 +0,0 @@ -(in-package :alexandria) - -(defun featurep (feature-expression) - "Returns T if the argument matches the state of the *FEATURES* -list and NIL if it does not. FEATURE-EXPRESSION can be any atom -or list acceptable to the reader macros #+ and #-." - (etypecase feature-expression - (symbol (not (null (member feature-expression *features*)))) - (cons (check-type (first feature-expression) symbol) - (eswitch ((first feature-expression) :test 'string=) - (:and (every #'featurep (rest feature-expression))) - (:or (some #'featurep (rest feature-expression))) - (:not (assert (= 2 (length feature-expression))) - (not (featurep (second feature-expression)))))))) diff --git a/third_party/lisp/alexandria/functions.lisp b/third_party/lisp/alexandria/functions.lisp deleted file mode 100644 index dd83e38b4e..0000000000 --- a/third_party/lisp/alexandria/functions.lisp +++ /dev/null @@ -1,161 +0,0 @@ -(in-package :alexandria) - -;;; To propagate return type and allow the compiler to eliminate the IF when -;;; it is known if the argument is function or not. -(declaim (inline ensure-function)) - -(declaim (ftype (function (t) (values function &optional)) - ensure-function)) -(defun ensure-function (function-designator) - "Returns the function designated by FUNCTION-DESIGNATOR: -if FUNCTION-DESIGNATOR is a function, it is returned, otherwise -it must be a function name and its FDEFINITION is returned." - (if (functionp function-designator) - function-designator - (fdefinition function-designator))) - -(define-modify-macro ensure-functionf/1 () ensure-function) - -(defmacro ensure-functionf (&rest places) - "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of -PLACES contains a function." - `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places))) - -(defun disjoin (predicate &rest more-predicates) - "Returns a function that applies each of PREDICATE and MORE-PREDICATE -functions in turn to its arguments, returning the primary value of the first -predicate that returns true, without calling the remaining predicates. -If none of the predicates returns true, NIL is returned." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let ((predicate (ensure-function predicate)) - (more-predicates (mapcar #'ensure-function more-predicates))) - (lambda (&rest arguments) - (or (apply predicate arguments) - (some (lambda (p) - (declare (type function p)) - (apply p arguments)) - more-predicates))))) - -(defun conjoin (predicate &rest more-predicates) - "Returns a function that applies each of PREDICATE and MORE-PREDICATE -functions in turn to its arguments, returning NIL if any of the predicates -returns false, without calling the remaining predicates. If none of the -predicates returns false, returns the primary value of the last predicate." - (if (null more-predicates) - predicate - (lambda (&rest arguments) - (and (apply predicate arguments) - ;; Cannot simply use CL:EVERY because we want to return the - ;; non-NIL value of the last predicate if all succeed. - (do ((tail (cdr more-predicates) (cdr tail)) - (head (car more-predicates) (car tail))) - ((not tail) - (apply head arguments)) - (unless (apply head arguments) - (return nil))))))) - - -(defun compose (function &rest more-functions) - "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its -arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS, -and then calling the next one with the primary value of the last." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (reduce (lambda (f g) - (let ((f (ensure-function f)) - (g (ensure-function g))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - (funcall f (apply g arguments))))) - more-functions - :initial-value function)) - -(define-compiler-macro compose (function &rest more-functions) - (labels ((compose-1 (funs) - (if (cdr funs) - `(funcall ,(car funs) ,(compose-1 (cdr funs))) - `(apply ,(car funs) arguments)))) - (let* ((args (cons function more-functions)) - (funs (make-gensym-list (length args) "COMPOSE"))) - `(let ,(loop for f in funs for arg in args - collect `(,f (ensure-function ,arg))) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - ,(compose-1 funs)))))) - -(defun multiple-value-compose (function &rest more-functions) - "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies -its arguments to each in turn, starting from the rightmost of -MORE-FUNCTIONS, and then calling the next one with all the return values of -the last." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (reduce (lambda (f g) - (let ((f (ensure-function f)) - (g (ensure-function g))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - (multiple-value-call f (apply g arguments))))) - more-functions - :initial-value function)) - -(define-compiler-macro multiple-value-compose (function &rest more-functions) - (labels ((compose-1 (funs) - (if (cdr funs) - `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs))) - `(apply ,(car funs) arguments)))) - (let* ((args (cons function more-functions)) - (funs (make-gensym-list (length args) "MV-COMPOSE"))) - `(let ,(mapcar #'list funs args) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - ,(compose-1 funs)))))) - -(declaim (inline curry rcurry)) - -(defun curry (function &rest arguments) - "Returns a function that applies ARGUMENTS and the arguments -it is called with to FUNCTION." - (declare (optimize (speed 3) (safety 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - ;; Using M-V-C we don't need to append the arguments. - (multiple-value-call fn (values-list arguments) (values-list more))))) - -(define-compiler-macro curry (function &rest arguments) - (let ((curries (make-gensym-list (length arguments) "CURRY")) - (fun (gensym "FUN"))) - `(let ((,fun (ensure-function ,function)) - ,@(mapcar #'list curries arguments)) - (declare (optimize (speed 3) (safety 1))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (apply ,fun ,@curries more))))) - -(defun rcurry (function &rest arguments) - "Returns a function that applies the arguments it is called -with and ARGUMENTS to FUNCTION." - (declare (optimize (speed 3) (safety 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (multiple-value-call fn (values-list more) (values-list arguments))))) - -(define-compiler-macro rcurry (function &rest arguments) - (let ((rcurries (make-gensym-list (length arguments) "RCURRY")) - (fun (gensym "FUN"))) - `(let ((,fun (ensure-function ,function)) - ,@(mapcar #'list rcurries arguments)) - (declare (optimize (speed 3) (safety 1))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (multiple-value-call ,fun (values-list more) ,@rcurries))))) - -(declaim (notinline curry rcurry)) - -(defmacro named-lambda (name lambda-list &body body) - "Expands into a lambda-expression within whose BODY NAME denotes the -corresponding function." - `(labels ((,name ,lambda-list ,@body)) - #',name)) diff --git a/third_party/lisp/alexandria/hash-tables.lisp b/third_party/lisp/alexandria/hash-tables.lisp deleted file mode 100644 index a9f7902204..0000000000 --- a/third_party/lisp/alexandria/hash-tables.lisp +++ /dev/null @@ -1,101 +0,0 @@ -(in-package :alexandria) - -(defmacro ensure-gethash (key hash-table &optional default) - "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT -under key before returning it. Secondary return value is true if key was -already in the table." - (once-only (key hash-table) - (with-unique-names (value presentp) - `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table) - (if ,presentp - (values ,value ,presentp) - (values (setf (gethash ,key ,hash-table) ,default) nil)))))) - -(defun copy-hash-table (table &key key test size - rehash-size rehash-threshold) - "Returns a copy of hash table TABLE, with the same keys and values -as the TABLE. The copy has the same properties as the original, unless -overridden by the keyword arguments. - -Before each of the original values is set into the new hash-table, KEY -is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow -copy is returned by default." - (setf key (or key 'identity)) - (setf test (or test (hash-table-test table))) - (setf size (or size (hash-table-size table))) - (setf rehash-size (or rehash-size (hash-table-rehash-size table))) - (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table))) - (let ((copy (make-hash-table :test test :size size - :rehash-size rehash-size - :rehash-threshold rehash-threshold))) - (maphash (lambda (k v) - (setf (gethash k copy) (funcall key v))) - table) - copy)) - -(declaim (inline maphash-keys)) -(defun maphash-keys (function table) - "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE." - (maphash (lambda (k v) - (declare (ignore v)) - (funcall function k)) - table)) - -(declaim (inline maphash-values)) -(defun maphash-values (function table) - "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE." - (maphash (lambda (k v) - (declare (ignore k)) - (funcall function v)) - table)) - -(defun hash-table-keys (table) - "Returns a list containing the keys of hash table TABLE." - (let ((keys nil)) - (maphash-keys (lambda (k) - (push k keys)) - table) - keys)) - -(defun hash-table-values (table) - "Returns a list containing the values of hash table TABLE." - (let ((values nil)) - (maphash-values (lambda (v) - (push v values)) - table) - values)) - -(defun hash-table-alist (table) - "Returns an association list containing the keys and values of hash table -TABLE." - (let ((alist nil)) - (maphash (lambda (k v) - (push (cons k v) alist)) - table) - alist)) - -(defun hash-table-plist (table) - "Returns a property list containing the keys and values of hash table -TABLE." - (let ((plist nil)) - (maphash (lambda (k v) - (setf plist (list* k v plist))) - table) - plist)) - -(defun alist-hash-table (alist &rest hash-table-initargs) - "Returns a hash table containing the keys and values of the association list -ALIST. Hash table is initialized using the HASH-TABLE-INITARGS." - (let ((table (apply #'make-hash-table hash-table-initargs))) - (dolist (cons alist) - (ensure-gethash (car cons) table (cdr cons))) - table)) - -(defun plist-hash-table (plist &rest hash-table-initargs) - "Returns a hash table containing the keys and values of the property list -PLIST. Hash table is initialized using the HASH-TABLE-INITARGS." - (let ((table (apply #'make-hash-table hash-table-initargs))) - (do ((tail plist (cddr tail))) - ((not tail)) - (ensure-gethash (car tail) table (cadr tail))) - table)) diff --git a/third_party/lisp/alexandria/io.lisp b/third_party/lisp/alexandria/io.lisp deleted file mode 100644 index 28bf5e6d82..0000000000 --- a/third_party/lisp/alexandria/io.lisp +++ /dev/null @@ -1,172 +0,0 @@ -;; Copyright (c) 2002-2006, Edward Marco Baringer -;; All rights reserved. - -(in-package :alexandria) - -(defmacro with-open-file* ((stream filespec &key direction element-type - if-exists if-does-not-exist external-format) - &body body) - "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use -the default value specified for OPEN." - (once-only (direction element-type if-exists if-does-not-exist external-format) - `(with-open-stream - (,stream (apply #'open ,filespec - (append - (when ,direction - (list :direction ,direction)) - (when ,element-type - (list :element-type ,element-type)) - (when ,if-exists - (list :if-exists ,if-exists)) - (when ,if-does-not-exist - (list :if-does-not-exist ,if-does-not-exist)) - (when ,external-format - (list :external-format ,external-format))))) - ,@body))) - -(defmacro with-input-from-file ((stream-name file-name &rest args - &key (direction nil direction-p) - &allow-other-keys) - &body body) - "Evaluate BODY with STREAM-NAME to an input stream on the file -FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT, -which is only sent to WITH-OPEN-FILE when it's not NIL." - (declare (ignore direction)) - (when direction-p - (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE.")) - `(with-open-file* (,stream-name ,file-name :direction :input ,@args) - ,@body)) - -(defmacro with-output-to-file ((stream-name file-name &rest args - &key (direction nil direction-p) - &allow-other-keys) - &body body) - "Evaluate BODY with STREAM-NAME to an output stream on the file -FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT, -which is only sent to WITH-OPEN-FILE when it's not NIL." - (declare (ignore direction)) - (when direction-p - (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE.")) - `(with-open-file* (,stream-name ,file-name :direction :output ,@args) - ,@body)) - -(defun read-stream-content-into-string (stream &key (buffer-size 4096)) - "Return the \"content\" of STREAM as a fresh string." - (check-type buffer-size positive-integer) - (let ((*print-pretty* nil)) - (with-output-to-string (datum) - (let ((buffer (make-array buffer-size :element-type 'character))) - (loop - :for bytes-read = (read-sequence buffer stream) - :do (write-sequence buffer datum :start 0 :end bytes-read) - :while (= bytes-read buffer-size)))))) - -(defun read-file-into-string (pathname &key (buffer-size 4096) external-format) - "Return the contents of the file denoted by PATHNAME as a fresh string. - -The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE -unless it's NIL, which means the system default." - (with-input-from-file - (file-stream pathname :external-format external-format) - (read-stream-content-into-string file-stream :buffer-size buffer-size))) - -(defun write-string-into-file (string pathname &key (if-exists :error) - if-does-not-exist - external-format) - "Write STRING to PATHNAME. - -The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE -unless it's NIL, which means the system default." - (with-output-to-file (file-stream pathname :if-exists if-exists - :if-does-not-exist if-does-not-exist - :external-format external-format) - (write-sequence string file-stream))) - -(defun read-stream-content-into-byte-vector (stream &key ((%length length)) - (initial-size 4096)) - "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector." - (check-type length (or null non-negative-integer)) - (check-type initial-size positive-integer) - (do ((buffer (make-array (or length initial-size) - :element-type '(unsigned-byte 8))) - (offset 0) - (offset-wanted 0)) - ((or (/= offset-wanted offset) - (and length (>= offset length))) - (if (= offset (length buffer)) - buffer - (subseq buffer 0 offset))) - (unless (zerop offset) - (let ((new-buffer (make-array (* 2 (length buffer)) - :element-type '(unsigned-byte 8)))) - (replace new-buffer buffer) - (setf buffer new-buffer))) - (setf offset-wanted (length buffer) - offset (read-sequence buffer stream :start offset)))) - -(defun read-file-into-byte-vector (pathname) - "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector." - (with-input-from-file (stream pathname :element-type '(unsigned-byte 8)) - (read-stream-content-into-byte-vector stream '%length (file-length stream)))) - -(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error) - if-does-not-exist) - "Write BYTES to PATHNAME." - (check-type bytes (vector (unsigned-byte 8))) - (with-output-to-file (stream pathname :if-exists if-exists - :if-does-not-exist if-does-not-exist - :element-type '(unsigned-byte 8)) - (write-sequence bytes stream))) - -(defun copy-file (from to &key (if-to-exists :supersede) - (element-type '(unsigned-byte 8)) finish-output) - (with-input-from-file (input from :element-type element-type) - (with-output-to-file (output to :element-type element-type - :if-exists if-to-exists) - (copy-stream input output - :element-type element-type - :finish-output finish-output)))) - -(defun copy-stream (input output &key (element-type (stream-element-type input)) - (buffer-size 4096) - (buffer (make-array buffer-size :element-type element-type)) - (start 0) end - finish-output) - "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must -be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have -compatible element-types." - (check-type start non-negative-integer) - (check-type end (or null non-negative-integer)) - (check-type buffer-size positive-integer) - (when (and end - (< end start)) - (error "END is smaller than START in ~S" 'copy-stream)) - (let ((output-position 0) - (input-position 0)) - (unless (zerop start) - ;; FIXME add platform specific optimization to skip seekable streams - (loop while (< input-position start) - do (let ((n (read-sequence buffer input - :end (min (length buffer) - (- start input-position))))) - (when (zerop n) - (error "~@<Could not read enough bytes from the input to fulfill ~ - the :START ~S requirement in ~S.~:@>" 'copy-stream start)) - (incf input-position n)))) - (assert (= input-position start)) - (loop while (or (null end) (< input-position end)) - do (let ((n (read-sequence buffer input - :end (when end - (min (length buffer) - (- end input-position)))))) - (when (zerop n) - (if end - (error "~@<Could not read enough bytes from the input to fulfill ~ - the :END ~S requirement in ~S.~:@>" 'copy-stream end) - (return))) - (incf input-position n) - (write-sequence buffer output :end n) - (incf output-position n))) - (when finish-output - (finish-output output)) - output-position)) diff --git a/third_party/lisp/alexandria/lists.lisp b/third_party/lisp/alexandria/lists.lisp deleted file mode 100644 index 51286071eb..0000000000 --- a/third_party/lisp/alexandria/lists.lisp +++ /dev/null @@ -1,367 +0,0 @@ -(in-package :alexandria) - -(declaim (inline safe-endp)) -(defun safe-endp (x) - (declare (optimize safety)) - (endp x)) - -(defun alist-plist (alist) - "Returns a property list containing the same keys and values as the -association list ALIST in the same order." - (let (plist) - (dolist (pair alist) - (push (car pair) plist) - (push (cdr pair) plist)) - (nreverse plist))) - -(defun plist-alist (plist) - "Returns an association list containing the same keys and values as the -property list PLIST in the same order." - (let (alist) - (do ((tail plist (cddr tail))) - ((safe-endp tail) (nreverse alist)) - (push (cons (car tail) (cadr tail)) alist)))) - -(declaim (inline racons)) -(defun racons (key value ralist) - (acons value key ralist)) - -(macrolet - ((define-alist-get (name get-entry get-value-from-entry add doc) - `(progn - (declaim (inline ,name)) - (defun ,name (alist key &key (test 'eql)) - ,doc - (let ((entry (,get-entry key alist :test test))) - (values (,get-value-from-entry entry) entry))) - (define-setf-expander ,name (place key &key (test ''eql) - &environment env) - (multiple-value-bind - (temporary-variables initforms newvals setter getter) - (get-setf-expansion place env) - (when (cdr newvals) - (error "~A cannot store multiple values in one place" ',name)) - (with-unique-names (new-value key-val test-val alist entry) - (values - (append temporary-variables - (list alist - key-val - test-val - entry)) - (append initforms - (list getter - key - test - `(,',get-entry ,key-val ,alist :test ,test-val))) - `(,new-value) - `(cond - (,entry - (setf (,',get-value-from-entry ,entry) ,new-value)) - (t - (let ,newvals - (setf ,(first newvals) (,',add ,key ,new-value ,alist)) - ,setter - ,new-value))) - `(,',get-value-from-entry ,entry)))))))) - (define-alist-get assoc-value assoc cdr acons -"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can -be used with SETF.") - (define-alist-get rassoc-value rassoc car racons -"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can -be used with SETF.")) - -(defun malformed-plist (plist) - (error "Malformed plist: ~S" plist)) - -(defmacro doplist ((key val plist &optional values) &body body) - "Iterates over elements of PLIST. BODY can be preceded by -declarations, and is like a TAGBODY. RETURN may be used to terminate -the iteration early. If RETURN is not used, returns VALUES." - (multiple-value-bind (forms declarations) (parse-body body) - (with-gensyms (tail loop results) - `(block nil - (flet ((,results () - (let (,key ,val) - (declare (ignorable ,key ,val)) - (return ,values)))) - (let* ((,tail ,plist) - (,key (if ,tail - (pop ,tail) - (,results))) - (,val (if ,tail - (pop ,tail) - (malformed-plist ',plist)))) - (declare (ignorable ,key ,val)) - ,@declarations - (tagbody - ,loop - ,@forms - (setf ,key (if ,tail - (pop ,tail) - (,results)) - ,val (if ,tail - (pop ,tail) - (malformed-plist ',plist))) - (go ,loop)))))))) - -(define-modify-macro appendf (&rest lists) append - "Modify-macro for APPEND. Appends LISTS to the place designated by the first -argument.") - -(define-modify-macro nconcf (&rest lists) nconc - "Modify-macro for NCONC. Concatenates LISTS to place designated by the first -argument.") - -(define-modify-macro unionf (list &rest args) union - "Modify-macro for UNION. Saves the union of LIST and the contents of the -place designated by the first argument to the designated place.") - -(define-modify-macro nunionf (list &rest args) nunion - "Modify-macro for NUNION. Saves the union of LIST and the contents of the -place designated by the first argument to the designated place. May modify -either argument.") - -(define-modify-macro reversef () reverse - "Modify-macro for REVERSE. Copies and reverses the list stored in the given -place and saves back the result into the place.") - -(define-modify-macro nreversef () nreverse - "Modify-macro for NREVERSE. Reverses the list stored in the given place by -destructively modifying it and saves back the result into the place.") - -(defun circular-list (&rest elements) - "Creates a circular list of ELEMENTS." - (let ((cycle (copy-list elements))) - (nconc cycle cycle))) - -(defun circular-list-p (object) - "Returns true if OBJECT is a circular list, NIL otherwise." - (and (listp object) - (do ((fast object (cddr fast)) - (slow (cons (car object) (cdr object)) (cdr slow))) - (nil) - (unless (and (consp fast) (listp (cdr fast))) - (return nil)) - (when (eq fast slow) - (return t))))) - -(defun circular-tree-p (object) - "Returns true if OBJECT is a circular tree, NIL otherwise." - (labels ((circularp (object seen) - (and (consp object) - (do ((fast (cons (car object) (cdr object)) (cddr fast)) - (slow object (cdr slow))) - (nil) - (when (or (eq fast slow) (member slow seen)) - (return-from circular-tree-p t)) - (when (or (not (consp fast)) (not (consp (cdr slow)))) - (return - (do ((tail object (cdr tail))) - ((not (consp tail)) - nil) - (let ((elt (car tail))) - (circularp elt (cons object seen)))))))))) - (circularp object nil))) - -(defun proper-list-p (object) - "Returns true if OBJECT is a proper list." - (cond ((not object) - t) - ((consp object) - (do ((fast object (cddr fast)) - (slow (cons (car object) (cdr object)) (cdr slow))) - (nil) - (unless (and (listp fast) (consp (cdr fast))) - (return (and (listp fast) (not (cdr fast))))) - (when (eq fast slow) - (return nil)))) - (t - nil))) - -(deftype proper-list () - "Type designator for proper lists. Implemented as a SATISFIES type, hence -not recommended for performance intensive use. Main usefullness as a type -designator of the expected type in a TYPE-ERROR." - `(and list (satisfies proper-list-p))) - -(defun circular-list-error (list) - (error 'type-error - :datum list - :expected-type '(and list (not circular-list)))) - -(macrolet ((def (name lambda-list doc step declare ret1 ret2) - (assert (member 'list lambda-list)) - `(defun ,name ,lambda-list - ,doc - (do ((last list fast) - (fast list (cddr fast)) - (slow (cons (car list) (cdr list)) (cdr slow)) - ,@(when step (list step))) - (nil) - (declare (dynamic-extent slow) ,@(when declare (list declare)) - (ignorable last)) - (when (safe-endp fast) - (return ,ret1)) - (when (safe-endp (cdr fast)) - (return ,ret2)) - (when (eq fast slow) - (circular-list-error list)))))) - (def proper-list-length (list) - "Returns length of LIST, signalling an error if it is not a proper list." - (n 1 (+ n 2)) - ;; KLUDGE: Most implementations don't actually support lists with bignum - ;; elements -- and this is WAY faster on most implementations then declaring - ;; N to be an UNSIGNED-BYTE. - (fixnum n) - (1- n) - n) - - (def lastcar (list) - "Returns the last element of LIST. Signals a type-error if LIST is not a -proper list." - nil - nil - (cadr last) - (car fast)) - - (def (setf lastcar) (object list) - "Sets the last element of LIST. Signals a type-error if LIST is not a proper -list." - nil - nil - (setf (cadr last) object) - (setf (car fast) object))) - -(defun make-circular-list (length &key initial-element) - "Creates a circular list of LENGTH with the given INITIAL-ELEMENT." - (let ((cycle (make-list length :initial-element initial-element))) - (nconc cycle cycle))) - -(deftype circular-list () - "Type designator for circular lists. Implemented as a SATISFIES type, so not -recommended for performance intensive use. Main usefullness as the -expected-type designator of a TYPE-ERROR." - `(satisfies circular-list-p)) - -(defun ensure-car (thing) - "If THING is a CONS, its CAR is returned. Otherwise THING is returned." - (if (consp thing) - (car thing) - thing)) - -(defun ensure-cons (cons) - "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS - in the car, and NIL in the cdr." - (if (consp cons) - cons - (cons cons nil))) - -(defun ensure-list (list) - "If LIST is a list, it is returned. Otherwise returns the list designated by LIST." - (if (listp list) - list - (list list))) - -(defun remove-from-plist (plist &rest keys) - "Returns a propery-list with same keys and values as PLIST, except that keys -in the list designated by KEYS and values corresponding to them are removed. -The returned property-list may share structure with the PLIST, but PLIST is -not destructively modified. Keys are compared using EQ." - (declare (optimize (speed 3))) - ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a) - ;; could return the tail without consing up a new list. - (loop for (key . rest) on plist by #'cddr - do (assert rest () "Expected a proper plist, got ~S" plist) - unless (member key keys :test #'eq) - collect key and collect (first rest))) - -(defun delete-from-plist (plist &rest keys) - "Just like REMOVE-FROM-PLIST, but this version may destructively modify the -provided PLIST." - (declare (optimize speed)) - (loop with head = plist - with tail = nil ; a nil tail means an empty result so far - for (key . rest) on plist by #'cddr - do (assert rest () "Expected a proper plist, got ~S" plist) - (if (member key keys :test #'eq) - ;; skip over this pair - (let ((next (cdr rest))) - (if tail - (setf (cdr tail) next) - (setf head next))) - ;; keep this pair - (setf tail rest)) - finally (return head))) - -(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist - "Modify macro for REMOVE-FROM-PLIST.") -(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist - "Modify macro for DELETE-FROM-PLIST.") - -(declaim (inline sans)) -(defun sans (plist &rest keys) - "Alias of REMOVE-FROM-PLIST for backward compatibility." - (apply #'remove-from-plist plist keys)) - -(defun mappend (function &rest lists) - "Applies FUNCTION to respective element(s) of each LIST, appending all the -all the result list to a single list. FUNCTION must return a list." - (loop for results in (apply #'mapcar function lists) - append results)) - -(defun setp (object &key (test #'eql) (key #'identity)) - "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list -denotes a set if each element of the list is unique under KEY and TEST." - (and (listp object) - (let (seen) - (dolist (elt object t) - (let ((key (funcall key elt))) - (if (member key seen :test test) - (return nil) - (push key seen))))))) - -(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) - "Returns true if every element of LIST1 matches some element of LIST2 and -every element of LIST2 matches some element of LIST1. Otherwise returns false." - (let ((keylist1 (if keyp (mapcar key list1) list1)) - (keylist2 (if keyp (mapcar key list2) list2))) - (and (dolist (elt keylist1 t) - (or (member elt keylist2 :test test) - (return nil))) - (dolist (elt keylist2 t) - (or (member elt keylist1 :test test) - (return nil)))))) - -(defun map-product (function list &rest more-lists) - "Returns a list containing the results of calling FUNCTION with one argument -from LIST, and one from each of MORE-LISTS for each combination of arguments. -In other words, returns the product of LIST and MORE-LISTS using FUNCTION. - -Example: - - (map-product 'list '(1 2) '(3 4) '(5 6)) - => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) - (2 3 5) (2 3 6) (2 4 5) (2 4 6)) -" - (labels ((%map-product (f lists) - (let ((more (cdr lists)) - (one (car lists))) - (if (not more) - (mapcar f one) - (mappend (lambda (x) - (%map-product (curry f x) more)) - one))))) - (%map-product (ensure-function function) (cons list more-lists)))) - -(defun flatten (tree) - "Traverses the tree in order, collecting non-null leaves into a list." - (let (list) - (labels ((traverse (subtree) - (when subtree - (if (consp subtree) - (progn - (traverse (car subtree)) - (traverse (cdr subtree))) - (push subtree list))))) - (traverse tree)) - (nreverse list))) diff --git a/third_party/lisp/alexandria/macros.lisp b/third_party/lisp/alexandria/macros.lisp deleted file mode 100644 index 4364ad63b8..0000000000 --- a/third_party/lisp/alexandria/macros.lisp +++ /dev/null @@ -1,370 +0,0 @@ -(in-package :alexandria) - -(defmacro with-gensyms (names &body forms) - "Binds a set of variables to gensyms and evaluates the implicit progn FORMS. - -Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL -STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL). - -Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL -should be bound to a symbol constructed using GENSYM with the string designated -by STRING-DESIGNATOR being its first argument." - `(let ,(mapcar (lambda (name) - (multiple-value-bind (symbol string) - (etypecase name - (symbol - (values name (symbol-name name))) - ((cons symbol (cons string-designator null)) - (values (first name) (string (second name))))) - `(,symbol (gensym ,string)))) - names) - ,@forms)) - -(defmacro with-unique-names (names &body forms) - "Alias for WITH-GENSYMS." - `(with-gensyms ,names ,@forms)) - -(defmacro once-only (specs &body forms) - "Constructs code whose primary goal is to help automate the handling of -multiple evaluation within macros. Multiple evaluation is handled by introducing -intermediate variables, in order to reuse the result of an expression. - -The returned value is a list of the form - - (let ((<gensym-1> <expr-1>) - ... - (<gensym-n> <expr-n>)) - <res>) - -where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order -to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of -evaluating the implicit progn FORMS within a special context determined by -SPECS. RES should make use of (reference) the intermediate variables. - -Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM). -Bare symbols are equivalent to the pair (SYMBOL SYMBOL). - -Each pair (SYMBOL INITFORM) specifies a single intermediate variable: - -- INITFORM is an expression evaluated to produce EXPR-i - -- SYMBOL is the name of the variable that will be bound around FORMS to the - corresponding gensym GENSYM-i, in order for FORMS to generate RES that - references the intermediate variable - -The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of -all the pairs are evaluated before binding SYMBOLs and evaluating FORMS. - -Example: - - The following expression - - (let ((x '(incf y))) - (once-only (x) - `(cons ,x ,x))) - - ;;; => - ;;; (let ((#1=#:X123 (incf y))) - ;;; (cons #1# #1#)) - - could be used within a macro to avoid multiple evaluation like so - - (defmacro cons1 (x) - (once-only (x) - `(cons ,x ,x))) - - (let ((y 0)) - (cons1 (incf y))) - - ;;; => (1 . 1) - -Example: - - The following expression demonstrates the usage of the INITFORM field - - (let ((expr '(incf y))) - (once-only ((var `(1+ ,expr))) - `(list ',expr ,var ,var))) - - ;;; => - ;;; (let ((#1=#:VAR123 (1+ (incf y)))) - ;;; (list '(incf y) #1# #1)) - - which could be used like so - - (defmacro print-succ-twice (expr) - (once-only ((var `(1+ ,expr))) - `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var))) - - (let ((y 10)) - (print-succ-twice (incf y))) - - ;;; >> - ;;; Expr: (INCF Y), Once: 12, Twice: 12" - (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) - (names-and-forms (mapcar (lambda (spec) - (etypecase spec - (list - (destructuring-bind (name form) spec - (cons name form))) - (symbol - (cons spec spec)))) - specs))) - ;; bind in user-macro - `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) - gensyms names-and-forms) - ;; bind in final expansion - `(let (,,@(mapcar (lambda (g n) - ``(,,g ,,(cdr n))) - gensyms names-and-forms)) - ;; bind in user-macro - ,(let ,(mapcar (lambda (n g) (list (car n) g)) - names-and-forms gensyms) - ,@forms))))) - -(defun parse-body (body &key documentation whole) - "Parses BODY into (values remaining-forms declarations doc-string). -Documentation strings are recognized only if DOCUMENTATION is true. -Syntax errors in body are signalled and WHOLE is used in the signal -arguments when given." - (let ((doc nil) - (decls nil) - (current nil)) - (tagbody - :declarations - (setf current (car body)) - (when (and documentation (stringp current) (cdr body)) - (if doc - (error "Too many documentation strings in ~S." (or whole body)) - (setf doc (pop body))) - (go :declarations)) - (when (and (listp current) (eql (first current) 'declare)) - (push (pop body) decls) - (go :declarations))) - (values body (nreverse decls) doc))) - -(defun parse-ordinary-lambda-list (lambda-list &key (normalize t) - allow-specializers - (normalize-optional normalize) - (normalize-keyword normalize) - (normalize-auxilary normalize)) - "Parses an ordinary lambda-list, returning as multiple values: - -1. Required parameters. - -2. Optional parameter specifications, normalized into form: - - (name init suppliedp) - -3. Name of the rest parameter, or NIL. - -4. Keyword parameter specifications, normalized into form: - - ((keyword-name name) init suppliedp) - -5. Boolean indicating &ALLOW-OTHER-KEYS presence. - -6. &AUX parameter specifications, normalized into form - - (name init). - -7. Existence of &KEY in the lambda-list. - -Signals a PROGRAM-ERROR is the lambda-list is malformed." - (let ((state :required) - (allow-other-keys nil) - (auxp nil) - (required nil) - (optional nil) - (rest nil) - (keys nil) - (keyp nil) - (aux nil)) - (labels ((fail (elt) - (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" - elt lambda-list)) - (check-variable (elt what &optional (allow-specializers allow-specializers)) - (unless (and (or (symbolp elt) - (and allow-specializers - (consp elt) (= 2 (length elt)) (symbolp (first elt)))) - (not (constantp elt))) - (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" - what elt lambda-list))) - (check-spec (spec what) - (destructuring-bind (init suppliedp) spec - (declare (ignore init)) - (check-variable suppliedp what nil)))) - (dolist (elt lambda-list) - (case elt - (&optional - (if (eq state :required) - (setf state elt) - (fail elt))) - (&rest - (if (member state '(:required &optional)) - (setf state elt) - (fail elt))) - (&key - (if (member state '(:required &optional :after-rest)) - (setf state elt) - (fail elt)) - (setf keyp t)) - (&allow-other-keys - (if (eq state '&key) - (setf allow-other-keys t - state elt) - (fail elt))) - (&aux - (cond ((eq state '&rest) - (fail elt)) - (auxp - (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" - elt lambda-list)) - (t - (setf auxp t - state elt)) - )) - (otherwise - (when (member elt '#.(set-difference lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux))) - (simple-program-error - "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" - elt lambda-list)) - (case state - (:required - (check-variable elt "required parameter") - (push elt required)) - (&optional - (cond ((consp elt) - (destructuring-bind (name &rest tail) elt - (check-variable name "optional parameter") - (cond ((cdr tail) - (check-spec tail "optional-supplied-p parameter")) - ((and normalize-optional tail) - (setf elt (append elt '(nil)))) - (normalize-optional - (setf elt (append elt '(nil nil))))))) - (t - (check-variable elt "optional parameter") - (when normalize-optional - (setf elt (cons elt '(nil nil)))))) - (push (ensure-list elt) optional)) - (&rest - (check-variable elt "rest parameter") - (setf rest elt - state :after-rest)) - (&key - (cond ((consp elt) - (destructuring-bind (var-or-kv &rest tail) elt - (cond ((consp var-or-kv) - (destructuring-bind (keyword var) var-or-kv - (unless (symbolp keyword) - (simple-program-error "Invalid keyword name ~S in ordinary ~ - lambda-list:~% ~S" - keyword lambda-list)) - (check-variable var "keyword parameter"))) - (t - (check-variable var-or-kv "keyword parameter") - (when normalize-keyword - (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))) - (cond ((cdr tail) - (check-spec tail "keyword-supplied-p parameter")) - ((and normalize-keyword tail) - (setf tail (append tail '(nil)))) - (normalize-keyword - (setf tail '(nil nil)))) - (setf elt (cons var-or-kv tail)))) - (t - (check-variable elt "keyword parameter") - (setf elt (if normalize-keyword - (list (list (make-keyword elt) elt) nil nil) - elt)))) - (push elt keys)) - (&aux - (if (consp elt) - (destructuring-bind (var &optional init) elt - (declare (ignore init)) - (check-variable var "&aux parameter")) - (progn - (check-variable elt "&aux parameter") - (setf elt (list* elt (when normalize-auxilary - '(nil)))))) - (push elt aux)) - (t - (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list))))))) - (values (nreverse required) (nreverse optional) rest (nreverse keys) - allow-other-keys (nreverse aux) keyp))) - -;;;; DESTRUCTURING-*CASE - -(defun expand-destructuring-case (key clauses case) - (once-only (key) - `(if (typep ,key 'cons) - (,case (car ,key) - ,@(mapcar (lambda (clause) - (destructuring-bind ((keys . lambda-list) &body body) clause - `(,keys - (destructuring-bind ,lambda-list (cdr ,key) - ,@body)))) - clauses)) - (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) - -(defmacro destructuring-case (keyform &body clauses) - "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND. -KEYFORM must evaluate to a CONS. - -Clauses are of the form: - - ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) - -The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE, -is selected, and FORMs are then executed with CDR of KEY is destructured and -bound by the DESTRUCTURING-LAMBDA-LIST. - -Example: - - (defun dcase (x) - (destructuring-case x - ((:foo a b) - (format nil \"foo: ~S, ~S\" a b)) - ((:bar &key a b) - (format nil \"bar: ~S, ~S\" a b)) - (((:alt1 :alt2) a) - (format nil \"alt: ~S\" a)) - ((t &rest rest) - (format nil \"unknown: ~S\" rest)))) - - (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" - (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" - (dcase (list :alt1 1)) ; => \"alt: 1\" - (dcase (list :alt2 2)) ; => \"alt: 2\" - (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" - - (defun decase (x) - (destructuring-case x - ((:foo a b) - (format nil \"foo: ~S, ~S\" a b)) - ((:bar &key a b) - (format nil \"bar: ~S, ~S\" a b)) - (((:alt1 :alt2) a) - (format nil \"alt: ~S\" a)))) - - (decase (list :foo 1 2)) ; => \"foo: 1, 2\" - (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" - (decase (list :alt1 1)) ; => \"alt: 1\" - (decase (list :alt2 2)) ; => \"alt: 2\" - (decase (list :quux 1 2 3)) ; =| error -" - (expand-destructuring-case keyform clauses 'case)) - -(defmacro destructuring-ccase (keyform &body clauses) - (expand-destructuring-case keyform clauses 'ccase)) - -(defmacro destructuring-ecase (keyform &body clauses) - (expand-destructuring-case keyform clauses 'ecase)) - -(dolist (name '(destructuring-ccase destructuring-ecase)) - (setf (documentation name 'function) (documentation 'destructuring-case 'function))) - - - diff --git a/third_party/lisp/alexandria/numbers.lisp b/third_party/lisp/alexandria/numbers.lisp deleted file mode 100644 index 1c06f71d50..0000000000 --- a/third_party/lisp/alexandria/numbers.lisp +++ /dev/null @@ -1,295 +0,0 @@ -(in-package :alexandria) - -(declaim (inline clamp)) -(defun clamp (number min max) - "Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then -MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER." - (if (< number min) - min - (if (> number max) - max - number))) - -(defun gaussian-random (&optional min max) - "Returns two gaussian random double floats as the primary and secondary value, -optionally constrained by MIN and MAX. Gaussian random numbers form a standard -normal distribution around 0.0d0. - -Sufficiently positive MIN or negative MAX will cause the algorithm used to -take a very long time. If MIN is positive it should be close to zero, and -similarly if MAX is negative it should be close to zero." - (macrolet - ((valid (x) - `(<= (or min ,x) ,x (or max ,x)) )) - (labels - ((gauss () - (loop - for x1 = (- (random 2.0d0) 1.0d0) - for x2 = (- (random 2.0d0) 1.0d0) - for w = (+ (expt x1 2) (expt x2 2)) - when (< w 1.0d0) - do (let ((v (sqrt (/ (* -2.0d0 (log w)) w)))) - (return (values (* x1 v) (* x2 v)))))) - (guard (x) - (unless (valid x) - (tagbody - :retry - (multiple-value-bind (x1 x2) (gauss) - (when (valid x1) - (setf x x1) - (go :done)) - (when (valid x2) - (setf x x2) - (go :done)) - (go :retry)) - :done)) - x)) - (multiple-value-bind - (g1 g2) (gauss) - (values (guard g1) (guard g2)))))) - -(declaim (inline iota)) -(defun iota (n &key (start 0) (step 1)) - "Return a list of n numbers, starting from START (with numeric contagion -from STEP applied), each consequtive number being the sum of the previous one -and STEP. START defaults to 0 and STEP to 1. - -Examples: - - (iota 4) => (0 1 2 3) - (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0) - (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2) -" - (declare (type (integer 0) n) (number start step)) - (loop ;; KLUDGE: get numeric contagion right for the first element too - for i = (+ (- (+ start step) step)) then (+ i step) - repeat n - collect i)) - -(declaim (inline map-iota)) -(defun map-iota (function n &key (start 0) (step 1)) - "Calls FUNCTION with N numbers, starting from START (with numeric contagion -from STEP applied), each consequtive number being the sum of the previous one -and STEP. START defaults to 0 and STEP to 1. Returns N. - -Examples: - - (map-iota #'print 3 :start 1 :step 1.0) => 3 - ;;; 1.0 - ;;; 2.0 - ;;; 3.0 -" - (declare (type (integer 0) n) (number start step)) - (loop ;; KLUDGE: get numeric contagion right for the first element too - for i = (+ start (- step step)) then (+ i step) - repeat n - do (funcall function i)) - n) - -(declaim (inline lerp)) -(defun lerp (v a b) - "Returns the result of linear interpolation between A and B, using the -interpolation coefficient V." - ;; The correct version is numerically stable, at the expense of an - ;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The - ;; unstable version can often be converted to a fast instruction on - ;; a lot of machines, though this is machine/implementation - ;; specific. As alexandria is more about correct code, than - ;; efficiency, and we're only talking about a single extra multiply, - ;; many would prefer the stable version - (+ (* (- 1.0 v) a) (* v b))) - -(declaim (inline mean)) -(defun mean (sample) - "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers." - (/ (reduce #'+ sample) (length sample))) - -(defun median (sample) - "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers." - ;; Implements and uses the quick-select algorithm to find the median - ;; https://en.wikipedia.org/wiki/Quickselect - - (labels ((randint-in-range (start-int end-int) - "Returns a random integer in the specified range, inclusive" - (+ start-int (random (1+ (- end-int start-int))))) - (partition (vec start-i end-i) - "Implements the partition function, which performs a partial - sort of vec around the (randomly) chosen pivot. - Returns the index where the pivot element would be located - in a correctly-sorted array" - (if (= start-i end-i) - start-i - (let ((pivot-i (randint-in-range start-i end-i))) - (rotatef (aref vec start-i) (aref vec pivot-i)) - (let ((swap-i end-i)) - (loop for i from swap-i downto (1+ start-i) do - (when (>= (aref vec i) (aref vec start-i)) - (rotatef (aref vec i) (aref vec swap-i)) - (decf swap-i))) - (rotatef (aref vec swap-i) (aref vec start-i)) - swap-i))))) - - (let* ((vector (copy-sequence 'vector sample)) - (len (length vector)) - (mid-i (ash len -1)) - (i 0) - (j (1- len))) - - (loop for correct-pos = (partition vector i j) - while (/= correct-pos mid-i) do - (if (< correct-pos mid-i) - (setf i (1+ correct-pos)) - (setf j (1- correct-pos)))) - - (if (oddp len) - (aref vector mid-i) - (* 1/2 - (+ (aref vector mid-i) - (reduce #'max (make-array - mid-i - :displaced-to vector)))))))) - -(declaim (inline variance)) -(defun variance (sample &key (biased t)) - "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default), -and the unbiased estimator of variance if BIASED is false. SAMPLE must be a -sequence of numbers." - (let ((mean (mean sample))) - (/ (reduce (lambda (a b) - (+ a (expt (- b mean) 2))) - sample - :initial-value 0) - (- (length sample) (if biased 0 1))))) - -(declaim (inline standard-deviation)) -(defun standard-deviation (sample &key (biased t)) - "Standard deviation of SAMPLE. Returns the biased standard deviation if -BIASED is true (the default), and the square root of the unbiased estimator -for variance if BIASED is false (which is not the same as the unbiased -estimator for standard deviation). SAMPLE must be a sequence of numbers." - (sqrt (variance sample :biased biased))) - -(define-modify-macro maxf (&rest numbers) max - "Modify-macro for MAX. Sets place designated by the first argument to the -maximum of its original value and NUMBERS.") - -(define-modify-macro minf (&rest numbers) min - "Modify-macro for MIN. Sets place designated by the first argument to the -minimum of its original value and NUMBERS.") - -;;;; Factorial - -;;; KLUDGE: This is really dependant on the numbers in question: for -;;; small numbers this is larger, and vice versa. Ideally instead of a -;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P. -(defconstant +factorial-bisection-range-limit+ 8) - -;;; KLUDGE: This is really platform dependant: ideally we would use -;;; (load-time-value (find-good-direct-multiplication-limit)) instead. -(defconstant +factorial-direct-multiplication-limit+ 13) - -(defun %multiply-range (i j) - ;; We use a a bit of cleverness here: - ;; - ;; 1. For large factorials we bisect in order to avoid expensive bignum - ;; multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon, - ;; and once it does that all further multiplications will be with bignums. - ;; - ;; By instead doing the multiplication in a tree like - ;; ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8)) - ;; we manage to get less bignums. - ;; - ;; 2. Division isn't exactly free either, however, so we don't bisect - ;; all the way down, but multiply ranges of integers close to each - ;; other directly. - ;; - ;; For even better results it should be possible to use prime - ;; factorization magic, but Nikodemus ran out of steam. - ;; - ;; KLUDGE: We support factorials of bignums, but it seems quite - ;; unlikely anyone would ever be able to use them on a modern lisp, - ;; since the resulting numbers are unlikely to fit in memory... but - ;; it would be extremely unelegant to define FACTORIAL only on - ;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be - ;; needed. - (labels ((bisect (j k) - (declare (type (integer 1 #.most-positive-fixnum) j k)) - (if (< (- k j) +factorial-bisection-range-limit+) - (multiply-range j k) - (let ((middle (+ j (truncate (- k j) 2)))) - (* (bisect j middle) - (bisect (+ middle 1) k))))) - (bisect-big (j k) - (declare (type (integer 1) j k)) - (if (= j k) - j - (let ((middle (+ j (truncate (- k j) 2)))) - (* (if (<= middle most-positive-fixnum) - (bisect j middle) - (bisect-big j middle)) - (bisect-big (+ middle 1) k))))) - (multiply-range (j k) - (declare (type (integer 1 #.most-positive-fixnum) j k)) - (do ((f k (* f m)) - (m (1- k) (1- m))) - ((< m j) f) - (declare (type (integer 0 (#.most-positive-fixnum)) m) - (type unsigned-byte f))))) - (if (and (typep i 'fixnum) (typep j 'fixnum)) - (bisect i j) - (bisect-big i j)))) - -(declaim (inline factorial)) -(defun %factorial (n) - (if (< n 2) - 1 - (%multiply-range 1 n))) - -(defun factorial (n) - "Factorial of non-negative integer N." - (check-type n (integer 0)) - (%factorial n)) - -;;;; Combinatorics - -(defun binomial-coefficient (n k) - "Binomial coefficient of N and K, also expressed as N choose K. This is the -number of K element combinations given N choises. N must be equal to or -greater then K." - (check-type n (integer 0)) - (check-type k (integer 0)) - (assert (>= n k)) - (if (or (zerop k) (= n k)) - 1 - (let ((n-k (- n k))) - ;; Swaps K and N-K if K < N-K because the algorithm - ;; below is faster for bigger K and smaller N-K - (when (< k n-k) - (rotatef k n-k)) - (if (= 1 n-k) - n - ;; General case, avoid computing the 1x...xK twice: - ;; - ;; N! 1x...xN (K+1)x...xN - ;; -------- = ---------------- = ------------, N>1 - ;; K!(N-K)! 1x...xK x (N-K)! (N-K)! - (/ (%multiply-range (+ k 1) n) - (%factorial n-k)))))) - -(defun subfactorial (n) - "Subfactorial of the non-negative integer N." - (check-type n (integer 0)) - (if (zerop n) - 1 - (do ((x 1 (1+ x)) - (a 0 (* x (+ a b))) - (b 1 a)) - ((= n x) a)))) - -(defun count-permutations (n &optional (k n)) - "Number of K element permutations for a sequence of N objects. -K defaults to N" - (check-type n (integer 0)) - (check-type k (integer 0)) - (assert (>= n k)) - (%multiply-range (1+ (- n k)) n)) diff --git a/third_party/lisp/alexandria/package.lisp b/third_party/lisp/alexandria/package.lisp deleted file mode 100644 index f9d2014cd7..0000000000 --- a/third_party/lisp/alexandria/package.lisp +++ /dev/null @@ -1,243 +0,0 @@ -(defpackage :alexandria.1.0.0 - (:nicknames :alexandria) - (:use :cl) - #+sb-package-locks - (:lock t) - (:export - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; BLESSED - ;; - ;; Binding constructs - #:if-let - #:when-let - #:when-let* - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; REVIEW IN PROGRESS - ;; - ;; Control flow - ;; - ;; -- no clear consensus yet -- - #:cswitch - #:eswitch - #:switch - ;; -- problem free? -- - #:multiple-value-prog2 - #:nth-value-or - #:whichever - #:xor - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; REVIEW PENDING - ;; - ;; Definitions - #:define-constant - ;; Hash tables - #:alist-hash-table - #:copy-hash-table - #:ensure-gethash - #:hash-table-alist - #:hash-table-keys - #:hash-table-plist - #:hash-table-values - #:maphash-keys - #:maphash-values - #:plist-hash-table - ;; Functions - #:compose - #:conjoin - #:curry - #:disjoin - #:ensure-function - #:ensure-functionf - #:multiple-value-compose - #:named-lambda - #:rcurry - ;; Lists - #:alist-plist - #:appendf - #:nconcf - #:reversef - #:nreversef - #:circular-list - #:circular-list-p - #:circular-tree-p - #:doplist - #:ensure-car - #:ensure-cons - #:ensure-list - #:flatten - #:lastcar - #:make-circular-list - #:map-product - #:mappend - #:nunionf - #:plist-alist - #:proper-list - #:proper-list-length - #:proper-list-p - #:remove-from-plist - #:remove-from-plistf - #:delete-from-plist - #:delete-from-plistf - #:set-equal - #:setp - #:unionf - ;; Numbers - #:binomial-coefficient - #:clamp - #:count-permutations - #:factorial - #:gaussian-random - #:iota - #:lerp - #:map-iota - #:maxf - #:mean - #:median - #:minf - #:standard-deviation - #:subfactorial - #:variance - ;; Arrays - #:array-index - #:array-length - #:copy-array - ;; Sequences - #:copy-sequence - #:deletef - #:emptyp - #:ends-with - #:ends-with-subseq - #:extremum - #:first-elt - #:last-elt - #:length= - #:map-combinations - #:map-derangements - #:map-permutations - #:proper-sequence - #:random-elt - #:removef - #:rotate - #:sequence-of-length-p - #:shuffle - #:starts-with - #:starts-with-subseq - ;; Macros - #:once-only - #:parse-body - #:parse-ordinary-lambda-list - #:with-gensyms - #:with-unique-names - ;; Symbols - #:ensure-symbol - #:format-symbol - #:make-gensym - #:make-gensym-list - #:make-keyword - ;; Strings - #:string-designator - ;; Types - #:negative-double-float - #:negative-fixnum-p - #:negative-float - #:negative-float-p - #:negative-long-float - #:negative-long-float-p - #:negative-rational - #:negative-rational-p - #:negative-real - #:negative-single-float-p - #:non-negative-double-float - #:non-negative-double-float-p - #:non-negative-fixnum - #:non-negative-fixnum-p - #:non-negative-float - #:non-negative-float-p - #:non-negative-integer-p - #:non-negative-long-float - #:non-negative-rational - #:non-negative-real-p - #:non-negative-short-float-p - #:non-negative-single-float - #:non-negative-single-float-p - #:non-positive-double-float - #:non-positive-double-float-p - #:non-positive-fixnum - #:non-positive-fixnum-p - #:non-positive-float - #:non-positive-float-p - #:non-positive-integer - #:non-positive-rational - #:non-positive-real - #:non-positive-real-p - #:non-positive-short-float - #:non-positive-short-float-p - #:non-positive-single-float-p - #:positive-double-float - #:positive-double-float-p - #:positive-fixnum - #:positive-fixnum-p - #:positive-float - #:positive-float-p - #:positive-integer - #:positive-rational - #:positive-real - #:positive-real-p - #:positive-short-float - #:positive-short-float-p - #:positive-single-float - #:positive-single-float-p - #:coercef - #:negative-double-float-p - #:negative-fixnum - #:negative-integer - #:negative-integer-p - #:negative-real-p - #:negative-short-float - #:negative-short-float-p - #:negative-single-float - #:non-negative-integer - #:non-negative-long-float-p - #:non-negative-rational-p - #:non-negative-real - #:non-negative-short-float - #:non-positive-integer-p - #:non-positive-long-float - #:non-positive-long-float-p - #:non-positive-rational-p - #:non-positive-single-float - #:of-type - #:positive-integer-p - #:positive-long-float - #:positive-long-float-p - #:positive-rational-p - #:type= - ;; Conditions - #:required-argument - #:ignore-some-conditions - #:simple-style-warning - #:simple-reader-error - #:simple-parse-error - #:simple-program-error - #:unwind-protect-case - ;; Features - #:featurep - ;; io - #:with-input-from-file - #:with-output-to-file - #:read-stream-content-into-string - #:read-file-into-string - #:write-string-into-file - #:read-stream-content-into-byte-vector - #:read-file-into-byte-vector - #:write-byte-vector-into-file - #:copy-stream - #:copy-file - ;; new additions collected at the end (subject to removal or further changes) - #:symbolicate - #:assoc-value - #:rassoc-value - #:destructuring-case - #:destructuring-ccase - #:destructuring-ecase - )) diff --git a/third_party/lisp/alexandria/sequences.lisp b/third_party/lisp/alexandria/sequences.lisp deleted file mode 100644 index 21464f5376..0000000000 --- a/third_party/lisp/alexandria/sequences.lisp +++ /dev/null @@ -1,555 +0,0 @@ -(in-package :alexandria) - -;; Make these inlinable by declaiming them INLINE here and some of them -;; NOTINLINE at the end of the file. Exclude functions that have a compiler -;; macro, because NOTINLINE is required to prevent compiler-macro expansion. -(declaim (inline copy-sequence sequence-of-length-p)) - -(defun sequence-of-length-p (sequence length) - "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if -SEQUENCE is not a sequence. Returns FALSE for circular lists." - (declare (type array-index length) - #-lispworks (inline length) - (optimize speed)) - (etypecase sequence - (null - (zerop length)) - (cons - (let ((n (1- length))) - (unless (minusp n) - (let ((tail (nthcdr n sequence))) - (and tail - (null (cdr tail))))))) - (vector - (= length (length sequence))) - (sequence - (= length (length sequence))))) - -(defun rotate-tail-to-head (sequence n) - (declare (type (integer 1) n)) - (if (listp sequence) - (let ((m (mod n (proper-list-length sequence)))) - (if (null (cdr sequence)) - sequence - (let* ((tail (last sequence (+ m 1))) - (last (cdr tail))) - (setf (cdr tail) nil) - (nconc last sequence)))) - (let* ((len (length sequence)) - (m (mod n len)) - (tail (subseq sequence (- len m)))) - (replace sequence sequence :start1 m :start2 0) - (replace sequence tail) - sequence))) - -(defun rotate-head-to-tail (sequence n) - (declare (type (integer 1) n)) - (if (listp sequence) - (let ((m (mod (1- n) (proper-list-length sequence)))) - (if (null (cdr sequence)) - sequence - (let* ((headtail (nthcdr m sequence)) - (tail (cdr headtail))) - (setf (cdr headtail) nil) - (nconc tail sequence)))) - (let* ((len (length sequence)) - (m (mod n len)) - (head (subseq sequence 0 m))) - (replace sequence sequence :start1 0 :start2 m) - (replace sequence head :start1 (- len m)) - sequence))) - -(defun rotate (sequence &optional (n 1)) - "Returns a sequence of the same type as SEQUENCE, with the elements of -SEQUENCE rotated by N: N elements are moved from the end of the sequence to -the front if N is positive, and -N elements moved from the front to the end if -N is negative. SEQUENCE must be a proper sequence. N must be an integer, -defaulting to 1. - -If absolute value of N is greater then the length of the sequence, the results -are identical to calling ROTATE with - - (* (signum n) (mod n (length sequence))). - -Note: the original sequence may be destructively altered, and result sequence may -share structure with it." - (if (plusp n) - (rotate-tail-to-head sequence n) - (if (minusp n) - (rotate-head-to-tail sequence (- n)) - sequence))) - -(defun shuffle (sequence &key (start 0) end) - "Returns a random permutation of SEQUENCE bounded by START and END. -Original sequence may be destructively modified, and (if it contains -CONS or lists themselv) share storage with the original one. -Signals an error if SEQUENCE is not a proper sequence." - (declare (type fixnum start) - (type (or fixnum null) end)) - (etypecase sequence - (list - (let* ((end (or end (proper-list-length sequence))) - (n (- end start))) - (do ((tail (nthcdr start sequence) (cdr tail))) - ((zerop n)) - (rotatef (car tail) (car (nthcdr (random n) tail))) - (decf n)))) - (vector - (let ((end (or end (length sequence)))) - (loop for i from start below end - do (rotatef (aref sequence i) - (aref sequence (+ i (random (- end i)))))))) - (sequence - (let ((end (or end (length sequence)))) - (loop for i from (- end 1) downto start - do (rotatef (elt sequence i) - (elt sequence (+ i (random (- end i))))))))) - sequence) - -(defun random-elt (sequence &key (start 0) end) - "Returns a random element from SEQUENCE bounded by START and END. Signals an -error if the SEQUENCE is not a proper non-empty sequence, or if END and START -are not proper bounding index designators for SEQUENCE." - (declare (sequence sequence) (fixnum start) (type (or fixnum null) end)) - (let* ((size (if (listp sequence) - (proper-list-length sequence) - (length sequence))) - (end2 (or end size))) - (cond ((zerop size) - (error 'type-error - :datum sequence - :expected-type `(and sequence (not (satisfies emptyp))))) - ((not (and (<= 0 start) (< start end2) (<= end2 size))) - (error 'simple-type-error - :datum (cons start end) - :expected-type `(cons (integer 0 (,end2)) - (or null (integer (,start) ,size))) - :format-control "~@<~S and ~S are not valid bounding index designators for ~ - a sequence of length ~S.~:@>" - :format-arguments (list start end size))) - (t - (let ((index (+ start (random (- end2 start))))) - (elt sequence index)))))) - -(declaim (inline remove/swapped-arguments)) -(defun remove/swapped-arguments (sequence item &rest keyword-arguments) - (apply #'remove item sequence keyword-arguments)) - -(define-modify-macro removef (item &rest keyword-arguments) - remove/swapped-arguments - "Modify-macro for REMOVE. Sets place designated by the first argument to -the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.") - -(declaim (inline delete/swapped-arguments)) -(defun delete/swapped-arguments (sequence item &rest keyword-arguments) - (apply #'delete item sequence keyword-arguments)) - -(define-modify-macro deletef (item &rest keyword-arguments) - delete/swapped-arguments - "Modify-macro for DELETE. Sets place designated by the first argument to -the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.") - -(deftype proper-sequence () - "Type designator for proper sequences, that is proper lists and sequences -that are not lists." - `(or proper-list - (and (not list) sequence))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (and (find-package '#:sequence) - (find-symbol (string '#:emptyp) '#:sequence)) - (pushnew 'sequence-emptyp *features*))) - -#-alexandria::sequence-emptyp -(defun emptyp (sequence) - "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE -is not a sequence." - (etypecase sequence - (list (null sequence)) - (sequence (zerop (length sequence))))) - -#+alexandria::sequence-emptyp -(declaim (ftype (function (sequence) (values boolean &optional)) emptyp)) -#+alexandria::sequence-emptyp -(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp)) -#+alexandria::sequence-emptyp -(define-compiler-macro emptyp (sequence) - `(sequence:emptyp ,sequence)) - -(defun length= (&rest sequences) - "Takes any number of sequences or integers in any order. Returns true iff -the length of all the sequences and the integers are equal. Hint: there's a -compiler macro that expands into more efficient code if the first argument -is a literal integer." - (declare (dynamic-extent sequences) - (inline sequence-of-length-p) - (optimize speed)) - (unless (cdr sequences) - (error "You must call LENGTH= with at least two arguments")) - ;; There's room for optimization here: multiple list arguments could be - ;; traversed in parallel. - (let* ((first (pop sequences)) - (current (if (integerp first) - first - (length first)))) - (declare (type array-index current)) - (dolist (el sequences) - (if (integerp el) - (unless (= el current) - (return-from length= nil)) - (unless (sequence-of-length-p el current) - (return-from length= nil))))) - t) - -(define-compiler-macro length= (&whole form length &rest sequences) - (cond - ((zerop (length sequences)) - form) - (t - (let ((optimizedp (integerp length))) - (with-unique-names (tmp current) - (declare (ignorable current)) - `(locally - (declare (inline sequence-of-length-p)) - (let ((,tmp) - ,@(unless optimizedp - `((,current ,length)))) - ,@(unless optimizedp - `((unless (integerp ,current) - (setf ,current (length ,current))))) - (and - ,@(loop - :for sequence :in sequences - :collect `(progn - (setf ,tmp ,sequence) - (if (integerp ,tmp) - (= ,tmp ,(if optimizedp - length - current)) - (sequence-of-length-p ,tmp ,(if optimizedp - length - current))))))))))))) - -(defun copy-sequence (type sequence) - "Returns a fresh sequence of TYPE, which has the same elements as -SEQUENCE." - (if (typep sequence type) - (copy-seq sequence) - (coerce sequence type))) - -(defun first-elt (sequence) - "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is -not a sequence, or is an empty sequence." - ;; Can't just directly use ELT, as it is not guaranteed to signal the - ;; type-error. - (cond ((consp sequence) - (car sequence)) - ((and (typep sequence 'sequence) (not (emptyp sequence))) - (elt sequence 0)) - (t - (error 'type-error - :datum sequence - :expected-type '(and sequence (not (satisfies emptyp))))))) - -(defun (setf first-elt) (object sequence) - "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is -not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE." - ;; Can't just directly use ELT, as it is not guaranteed to signal the - ;; type-error. - (cond ((consp sequence) - (setf (car sequence) object)) - ((and (typep sequence 'sequence) (not (emptyp sequence))) - (setf (elt sequence 0) object)) - (t - (error 'type-error - :datum sequence - :expected-type '(and sequence (not (satisfies emptyp))))))) - -(defun last-elt (sequence) - "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is -not a proper sequence, or is an empty sequence." - ;; Can't just directly use ELT, as it is not guaranteed to signal the - ;; type-error. - (let ((len 0)) - (cond ((consp sequence) - (lastcar sequence)) - ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence)))) - (elt sequence (1- len))) - (t - (error 'type-error - :datum sequence - :expected-type '(and proper-sequence (not (satisfies emptyp)))))))) - -(defun (setf last-elt) (object sequence) - "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper -sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE." - (let ((len 0)) - (cond ((consp sequence) - (setf (lastcar sequence) object)) - ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence)))) - (setf (elt sequence (1- len)) object)) - (t - (error 'type-error - :datum sequence - :expected-type '(and proper-sequence (not (satisfies emptyp)))))))) - -(defun starts-with-subseq (prefix sequence &rest args - &key - (return-suffix nil return-suffix-supplied-p) - &allow-other-keys) - "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX. - -If RETURN-SUFFIX is T the function returns, as a second value, a -sub-sequence or displaced array pointing to the sequence after PREFIX." - (declare (dynamic-extent args)) - (let ((sequence-length (length sequence)) - (prefix-length (length prefix))) - (when (< sequence-length prefix-length) - (return-from starts-with-subseq (values nil nil))) - (flet ((make-suffix (start) - (when return-suffix - (cond - ((not (arrayp sequence)) - (if start - (subseq sequence start) - (subseq sequence 0 0))) - ((not start) - (make-array 0 - :element-type (array-element-type sequence) - :adjustable nil)) - (t - (make-array (- sequence-length start) - :element-type (array-element-type sequence) - :displaced-to sequence - :displaced-index-offset start - :adjustable nil)))))) - (let ((mismatch (apply #'mismatch prefix sequence - (if return-suffix-supplied-p - (remove-from-plist args :return-suffix) - args)))) - (cond - ((not mismatch) - (values t (make-suffix nil))) - ((= mismatch prefix-length) - (values t (make-suffix mismatch))) - (t - (values nil nil))))))) - -(defun ends-with-subseq (suffix sequence &key (test #'eql)) - "Test whether SEQUENCE ends with SUFFIX. In other words: return true if -the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX." - (let ((sequence-length (length sequence)) - (suffix-length (length suffix))) - (when (< sequence-length suffix-length) - ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX. - (return-from ends-with-subseq nil)) - (loop for sequence-index from (- sequence-length suffix-length) below sequence-length - for suffix-index from 0 below suffix-length - when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index))) - do (return-from ends-with-subseq nil) - finally (return t)))) - -(defun starts-with (object sequence &key (test #'eql) (key #'identity)) - "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT. -Returns NIL if the SEQUENCE is not a sequence or is an empty sequence." - (let ((first-elt (typecase sequence - (cons (car sequence)) - (sequence - (if (emptyp sequence) - (return-from starts-with nil) - (elt sequence 0))) - (t - (return-from starts-with nil))))) - (funcall test (funcall key first-elt) object))) - -(defun ends-with (object sequence &key (test #'eql) (key #'identity)) - "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT. -Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals -an error if SEQUENCE is an improper list." - (let ((last-elt (typecase sequence - (cons - (lastcar sequence)) ; signals for improper lists - (sequence - ;; Can't use last-elt, as that signals an error - ;; for empty sequences - (let ((len (length sequence))) - (if (plusp len) - (elt sequence (1- len)) - (return-from ends-with nil)))) - (t - (return-from ends-with nil))))) - (funcall test (funcall key last-elt) object))) - -(defun map-combinations (function sequence &key (start 0) end length (copy t)) - "Calls FUNCTION with each combination of LENGTH constructable from the -elements of the subsequence of SEQUENCE delimited by START and END. START -defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the -delimited subsequence. (So unless LENGTH is specified there is only a single -combination, which has the same elements as the delimited subsequence.) If -COPY is true (the default) each combination is freshly allocated. If COPY is -false all combinations are EQ to each other, in which case consequences are -unspecified if a combination is modified by FUNCTION." - (let* ((end (or end (length sequence))) - (size (- end start)) - (length (or length size)) - (combination (subseq sequence 0 length)) - (function (ensure-function function))) - (if (= length size) - (funcall function combination) - (flet ((call () - (funcall function (if copy - (copy-seq combination) - combination)))) - (etypecase sequence - ;; When dealing with lists we prefer walking back and - ;; forth instead of using indexes. - (list - (labels ((combine-list (c-tail o-tail) - (if (not c-tail) - (call) - (do ((tail o-tail (cdr tail))) - ((not tail)) - (setf (car c-tail) (car tail)) - (combine-list (cdr c-tail) (cdr tail)))))) - (combine-list combination (nthcdr start sequence)))) - (vector - (labels ((combine (count start) - (if (zerop count) - (call) - (loop for i from start below end - do (let ((j (- count 1))) - (setf (aref combination j) (aref sequence i)) - (combine j (+ i 1))))))) - (combine length start))) - (sequence - (labels ((combine (count start) - (if (zerop count) - (call) - (loop for i from start below end - do (let ((j (- count 1))) - (setf (elt combination j) (elt sequence i)) - (combine j (+ i 1))))))) - (combine length start))))))) - sequence) - -(defun map-permutations (function sequence &key (start 0) end length (copy t)) - "Calls function with each permutation of LENGTH constructable -from the subsequence of SEQUENCE delimited by START and END. START -defaults to 0, END to length of the sequence, and LENGTH to the -length of the delimited subsequence." - (let* ((end (or end (length sequence))) - (size (- end start)) - (length (or length size))) - (labels ((permute (seq n) - (let ((n-1 (- n 1))) - (if (zerop n-1) - (funcall function (if copy - (copy-seq seq) - seq)) - (loop for i from 0 upto n-1 - do (permute seq n-1) - (if (evenp n-1) - (rotatef (elt seq 0) (elt seq n-1)) - (rotatef (elt seq i) (elt seq n-1))))))) - (permute-sequence (seq) - (permute seq length))) - (if (= length size) - ;; Things are simple if we need to just permute the - ;; full START-END range. - (permute-sequence (subseq sequence start end)) - ;; Otherwise we need to generate all the combinations - ;; of LENGTH in the START-END range, and then permute - ;; a copy of the result: can't permute the combination - ;; directly, as they share structure with each other. - (let ((permutation (subseq sequence 0 length))) - (flet ((permute-combination (combination) - (permute-sequence (replace permutation combination)))) - (declare (dynamic-extent #'permute-combination)) - (map-combinations #'permute-combination sequence - :start start - :end end - :length length - :copy nil))))))) - -(defun map-derangements (function sequence &key (start 0) end (copy t)) - "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted -by the bounding index designators START and END. Derangement is a permutation -of the sequence where no element remains in place. SEQUENCE is not modified, -but individual derangements are EQ to each other. Consequences are unspecified -if calling FUNCTION modifies either the derangement or SEQUENCE." - (let* ((end (or end (length sequence))) - (size (- end start)) - ;; We don't really care about the elements here. - (derangement (subseq sequence 0 size)) - ;; Bitvector that has 1 for elements that have been deranged. - (mask (make-array size :element-type 'bit :initial-element 0))) - (declare (dynamic-extent mask)) - ;; ad hoc algorith - (labels ((derange (place n) - ;; Perform one recursive step in deranging the - ;; sequence: PLACE is index of the original sequence - ;; to derange to another index, and N is the number of - ;; indexes not yet deranged. - (if (zerop n) - (funcall function (if copy - (copy-seq derangement) - derangement)) - ;; Itarate over the indexes I of the subsequence to - ;; derange: if I != PLACE and I has not yet been - ;; deranged by an earlier call put the element from - ;; PLACE to I, mark I as deranged, and recurse, - ;; finally removing the mark. - (loop for i from 0 below size - do - (unless (or (= place (+ i start)) (not (zerop (bit mask i)))) - (setf (elt derangement i) (elt sequence place) - (bit mask i) 1) - (derange (1+ place) (1- n)) - (setf (bit mask i) 0)))))) - (derange start size) - sequence))) - -(declaim (notinline sequence-of-length-p)) - -(defun extremum (sequence predicate &key key (start 0) end) - "Returns the element of SEQUENCE that would appear first if the subsequence -bounded by START and END was sorted using PREDICATE and KEY. - -EXTREMUM determines the relationship between two elements of SEQUENCE by using -the PREDICATE function. PREDICATE should return true if and only if the first -argument is strictly less than the second one (in some appropriate sense). Two -arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y) -and (FUNCALL PREDICATE Y X) are both false. - -The arguments to the PREDICATE function are computed from elements of SEQUENCE -using the KEY function, if supplied. If KEY is not supplied or is NIL, the -sequence element itself is used. - -If SEQUENCE is empty, NIL is returned." - (let* ((pred-fun (ensure-function predicate)) - (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity)) - (ensure-function key))) - (real-end (or end (length sequence)))) - (cond ((> real-end start) - (if key-fun - (flet ((reduce-keys (a b) - (if (funcall pred-fun - (funcall key-fun a) - (funcall key-fun b)) - a - b))) - (declare (dynamic-extent #'reduce-keys)) - (reduce #'reduce-keys sequence :start start :end real-end)) - (flet ((reduce-elts (a b) - (if (funcall pred-fun a b) - a - b))) - (declare (dynamic-extent #'reduce-elts)) - (reduce #'reduce-elts sequence :start start :end real-end)))) - ((= real-end start) - nil) - (t - (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S" - (length sequence) - :start start - :end end))))) diff --git a/third_party/lisp/alexandria/strings.lisp b/third_party/lisp/alexandria/strings.lisp deleted file mode 100644 index e9fd91c961..0000000000 --- a/third_party/lisp/alexandria/strings.lisp +++ /dev/null @@ -1,6 +0,0 @@ -(in-package :alexandria) - -(deftype string-designator () - "A string designator type. A string designator is either a string, a symbol, -or a character." - `(or symbol string character)) diff --git a/third_party/lisp/alexandria/symbols.lisp b/third_party/lisp/alexandria/symbols.lisp deleted file mode 100644 index 5733d3e1cc..0000000000 --- a/third_party/lisp/alexandria/symbols.lisp +++ /dev/null @@ -1,65 +0,0 @@ -(in-package :alexandria) - -(declaim (inline ensure-symbol)) -(defun ensure-symbol (name &optional (package *package*)) - "Returns a symbol with name designated by NAME, accessible in package -designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is -interned there. Returns a secondary value reflecting the status of the symbol -in the package, which matches the secondary return value of INTERN. - -Example: - - (ensure-symbol :cons :cl) => cl:cons, :external -" - (intern (string name) package)) - -(defun maybe-intern (name package) - (values - (if package - (intern name (if (eq t package) *package* package)) - (make-symbol name)))) - -(declaim (inline format-symbol)) -(defun format-symbol (package control &rest arguments) - "Constructs a string by applying ARGUMENTS to string designator CONTROL as -if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named -by that string. - -If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a -symbol interned in the current package, and otherwise returns a symbol -interned in the package designated by PACKAGE." - (maybe-intern (with-standard-io-syntax - (apply #'format nil (string control) arguments)) - package)) - -(defun make-keyword (name) - "Interns the string designated by NAME in the KEYWORD package." - (intern (string name) :keyword)) - -(defun make-gensym (name) - "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME -must be a string designator, in which case calls GENSYM using the designated -string as the argument." - (gensym (if (typep name '(integer 0)) - name - (string name)))) - -(defun make-gensym-list (length &optional (x "G")) - "Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM, -using the second (optional, defaulting to \"G\") argument." - (let ((g (if (typep x '(integer 0)) x (string x)))) - (loop repeat length - collect (gensym g)))) - -(defun symbolicate (&rest things) - "Concatenate together the names of some strings and symbols, -producing a symbol in the current package." - (let* ((length (reduce #'+ things - :key (lambda (x) (length (string x))))) - (name (make-array length :element-type 'character))) - (let ((index 0)) - (dolist (thing things (values (intern name))) - (let* ((x (string thing)) - (len (length x))) - (replace name x :start1 index) - (incf index len)))))) diff --git a/third_party/lisp/alexandria/tests.lisp b/third_party/lisp/alexandria/tests.lisp deleted file mode 100644 index b70ef0475e..0000000000 --- a/third_party/lisp/alexandria/tests.lisp +++ /dev/null @@ -1,2047 +0,0 @@ -(in-package :cl-user) - -(defpackage :alexandria-tests - (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest) - (:import-from #+sbcl :sb-rt #-sbcl :rtest - #:*compile-tests* #:*expected-failures*)) - -(in-package :alexandria-tests) - -(defun run-tests (&key ((:compiled *compile-tests*))) - (do-tests)) - -(defun hash-table-test-name (name) - ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL. - (hash-table-test (make-hash-table :test name))) - -;;;; Arrays - -(deftest copy-array.1 - (let* ((orig (vector 1 2 3)) - (copy (copy-array orig))) - (values (eq orig copy) (equalp orig copy))) - nil t) - -(deftest copy-array.2 - (let ((orig (make-array 1024 :fill-pointer 0))) - (vector-push-extend 1 orig) - (vector-push-extend 2 orig) - (vector-push-extend 3 orig) - (let ((copy (copy-array orig))) - (values (eq orig copy) (equalp orig copy) - (array-has-fill-pointer-p copy) - (eql (fill-pointer orig) (fill-pointer copy))))) - nil t t t) - -(deftest copy-array.3 - (let* ((orig (vector 1 2 3)) - (copy (copy-array orig))) - (typep copy 'simple-array)) - t) - -(deftest copy-array.4 - (let ((orig (make-array 21 - :adjustable t - :fill-pointer 0))) - (dotimes (n 42) - (vector-push-extend n orig)) - (let ((copy (copy-array orig - :adjustable nil - :fill-pointer nil))) - (typep copy 'simple-array))) - t) - -(deftest array-index.1 - (typep 0 'array-index) - t) - -;;;; Conditions - -(deftest unwind-protect-case.1 - (let (result) - (unwind-protect-case () - (random 10) - (:normal (push :normal result)) - (:abort (push :abort result)) - (:always (push :always result))) - result) - (:always :normal)) - -(deftest unwind-protect-case.2 - (let (result) - (unwind-protect-case () - (random 10) - (:always (push :always result)) - (:normal (push :normal result)) - (:abort (push :abort result))) - result) - (:normal :always)) - -(deftest unwind-protect-case.3 - (let (result1 result2 result3) - (ignore-errors - (unwind-protect-case () - (error "FOOF!") - (:normal (push :normal result1)) - (:abort (push :abort result1)) - (:always (push :always result1)))) - (catch 'foof - (unwind-protect-case () - (throw 'foof 42) - (:normal (push :normal result2)) - (:abort (push :abort result2)) - (:always (push :always result2)))) - (block foof - (unwind-protect-case () - (return-from foof 42) - (:normal (push :normal result3)) - (:abort (push :abort result3)) - (:always (push :always result3)))) - (values result1 result2 result3)) - (:always :abort) - (:always :abort) - (:always :abort)) - -(deftest unwind-protect-case.4 - (let (result) - (unwind-protect-case (aborted-p) - (random 42) - (:always (setq result aborted-p))) - result) - nil) - -(deftest unwind-protect-case.5 - (let (result) - (block foof - (unwind-protect-case (aborted-p) - (return-from foof) - (:always (setq result aborted-p)))) - result) - t) - -;;;; Control flow - -(deftest switch.1 - (switch (13 :test =) - (12 :oops) - (13.0 :yay)) - :yay) - -(deftest switch.2 - (switch (13) - ((+ 12 2) :oops) - ((- 13 1) :oops2) - (t :yay)) - :yay) - -(deftest eswitch.1 - (let ((x 13)) - (eswitch (x :test =) - (12 :oops) - (13.0 :yay))) - :yay) - -(deftest eswitch.2 - (let ((x 13)) - (eswitch (x :key 1+) - (11 :oops) - (14 :yay))) - :yay) - -(deftest cswitch.1 - (cswitch (13 :test =) - (12 :oops) - (13.0 :yay)) - :yay) - -(deftest cswitch.2 - (cswitch (13 :key 1-) - (12 :yay) - (13.0 :oops)) - :yay) - -(deftest multiple-value-prog2.1 - (multiple-value-prog2 - (values 1 1 1) - (values 2 20 200) - (values 3 3 3)) - 2 20 200) - -(deftest nth-value-or.1 - (multiple-value-bind (a b c) - (nth-value-or 1 - (values 1 nil 1) - (values 2 2 2)) - (= a b c 2)) - t) - -(deftest whichever.1 - (let ((x (whichever 1 2 3))) - (and (member x '(1 2 3)) t)) - t) - -(deftest whichever.2 - (let* ((a 1) - (b 2) - (c 3) - (x (whichever a b c))) - (and (member x '(1 2 3)) t)) - t) - -(deftest xor.1 - (xor nil nil 1 nil) - 1 - t) - -(deftest xor.2 - (xor nil nil 1 2) - nil - nil) - -(deftest xor.3 - (xor nil nil nil) - nil - t) - -;;;; Definitions - -(deftest define-constant.1 - (let ((name (gensym))) - (eval `(define-constant ,name "FOO" :test 'equal)) - (eval `(define-constant ,name "FOO" :test 'equal)) - (values (equal "FOO" (symbol-value name)) - (constantp name))) - t - t) - -(deftest define-constant.2 - (let ((name (gensym))) - (eval `(define-constant ,name 13)) - (eval `(define-constant ,name 13)) - (values (eql 13 (symbol-value name)) - (constantp name))) - t - t) - -;;;; Errors - -;;; TYPEP is specified to return a generalized boolean and, for -;;; example, ECL exploits this by returning the superclasses of ERROR -;;; in this case. -(defun errorp (x) - (not (null (typep x 'error)))) - -(deftest required-argument.1 - (multiple-value-bind (res err) - (ignore-errors (required-argument)) - (errorp err)) - t) - -;;;; Hash tables - -(deftest ensure-gethash.1 - (let ((table (make-hash-table)) - (x (list 1))) - (multiple-value-bind (value already-there) - (ensure-gethash x table 42) - (and (= value 42) - (not already-there) - (= 42 (gethash x table)) - (multiple-value-bind (value2 already-there2) - (ensure-gethash x table 13) - (and (= value2 42) - already-there2 - (= 42 (gethash x table))))))) - t) - -(deftest ensure-gethash.2 - (let ((table (make-hash-table)) - (count 0)) - (multiple-value-call #'values - (ensure-gethash (progn (incf count) :foo) - (progn (incf count) table) - (progn (incf count) :bar)) - (gethash :foo table) - count)) - :bar nil :bar t 3) - -(deftest copy-hash-table.1 - (let ((orig (make-hash-table :test 'eq :size 123)) - (foo "foo")) - (setf (gethash orig orig) t - (gethash foo orig) t) - (let ((eq-copy (copy-hash-table orig)) - (eql-copy (copy-hash-table orig :test 'eql)) - (equal-copy (copy-hash-table orig :test 'equal)) - (equalp-copy (copy-hash-table orig :test 'equalp))) - (list (eql (hash-table-size eq-copy) (hash-table-size orig)) - (eql (hash-table-rehash-size eq-copy) - (hash-table-rehash-size orig)) - (hash-table-count eql-copy) - (gethash orig eq-copy) - (gethash (copy-seq foo) eql-copy) - (gethash foo eql-copy) - (gethash (copy-seq foo) equal-copy) - (gethash "FOO" equal-copy) - (gethash "FOO" equalp-copy)))) - (t t 2 t nil t t nil t)) - -(deftest copy-hash-table.2 - (let ((ht (make-hash-table)) - (list (list :list (vector :A :B :C)))) - (setf (gethash 'list ht) list) - (let* ((shallow-copy (copy-hash-table ht)) - (deep1-copy (copy-hash-table ht :key 'copy-list)) - (list (gethash 'list ht)) - (shallow-list (gethash 'list shallow-copy)) - (deep1-list (gethash 'list deep1-copy))) - (list (eq ht shallow-copy) - (eq ht deep1-copy) - (eq list shallow-list) - (eq list deep1-list) ; outer list was copied. - (eq (second list) (second shallow-list)) - (eq (second list) (second deep1-list)) ; inner vector wasn't copied. - ))) - (nil nil t nil t t)) - -(deftest maphash-keys.1 - (let ((keys nil) - (table (make-hash-table))) - (declare (notinline maphash-keys)) - (dotimes (i 10) - (setf (gethash i table) t)) - (maphash-keys (lambda (k) (push k keys)) table) - (set-equal keys '(0 1 2 3 4 5 6 7 8 9))) - t) - -(deftest maphash-values.1 - (let ((vals nil) - (table (make-hash-table))) - (declare (notinline maphash-values)) - (dotimes (i 10) - (setf (gethash i table) (- i))) - (maphash-values (lambda (v) (push v vals)) table) - (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9))) - t) - -(deftest hash-table-keys.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash i table) t)) - (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9))) - t) - -(deftest hash-table-values.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash (gensym) table) i)) - (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9))) - t) - -(deftest hash-table-alist.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash i table) (- i))) - (let ((alist (hash-table-alist table))) - (list (length alist) - (assoc 0 alist) - (assoc 3 alist) - (assoc 9 alist) - (assoc nil alist)))) - (10 (0 . 0) (3 . -3) (9 . -9) nil)) - -(deftest hash-table-plist.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash i table) (- i))) - (let ((plist (hash-table-plist table))) - (list (length plist) - (getf plist 0) - (getf plist 2) - (getf plist 7) - (getf plist nil)))) - (20 0 -2 -7 nil)) - -(deftest alist-hash-table.1 - (let* ((alist '((0 a) (1 b) (2 c))) - (table (alist-hash-table alist))) - (list (hash-table-count table) - (gethash 0 table) - (gethash 1 table) - (gethash 2 table) - (eq (hash-table-test-name 'eql) - (hash-table-test table)))) - (3 (a) (b) (c) t)) - -(deftest alist-hash-table.duplicate-keys - (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e))) - (table (alist-hash-table alist))) - (list (hash-table-count table) - (gethash 0 table) - (gethash 1 table) - (gethash 2 table))) - (3 (a) (b) (e))) - -(deftest plist-hash-table.1 - (let* ((plist '(:a 1 :b 2 :c 3)) - (table (plist-hash-table plist :test 'eq))) - (list (hash-table-count table) - (gethash :a table) - (gethash :b table) - (gethash :c table) - (gethash 2 table) - (gethash nil table) - (eq (hash-table-test-name 'eq) - (hash-table-test table)))) - (3 1 2 3 nil nil t)) - -(deftest plist-hash-table.duplicate-keys - (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5)) - (table (plist-hash-table plist))) - (list (hash-table-count table) - (gethash :a table) - (gethash :b table) - (gethash :c table))) - (3 1 2 5)) - -;;;; Functions - -(deftest disjoin.1 - (let ((disjunction (disjoin (lambda (x) - (and (consp x) :cons)) - (lambda (x) - (and (stringp x) :string))))) - (list (funcall disjunction 'zot) - (funcall disjunction '(foo bar)) - (funcall disjunction "test"))) - (nil :cons :string)) - -(deftest disjoin.2 - (let ((disjunction (disjoin #'zerop))) - (list (funcall disjunction 0) - (funcall disjunction 1))) - (t nil)) - -(deftest conjoin.1 - (let ((conjunction (conjoin #'consp - (lambda (x) - (stringp (car x))) - (lambda (x) - (char (car x) 0))))) - (list (funcall conjunction 'zot) - (funcall conjunction '(foo)) - (funcall conjunction '("foo")))) - (nil nil #\f)) - -(deftest conjoin.2 - (let ((conjunction (conjoin #'zerop))) - (list (funcall conjunction 0) - (funcall conjunction 1))) - (t nil)) - -(deftest compose.1 - (let ((composite (compose '1+ - (lambda (x) - (* x 2)) - #'read-from-string))) - (funcall composite "1")) - 3) - -(deftest compose.2 - (let ((composite - (locally (declare (notinline compose)) - (compose '1+ - (lambda (x) - (* x 2)) - #'read-from-string)))) - (funcall composite "2")) - 5) - -(deftest compose.3 - (let ((compose-form (funcall (compiler-macro-function 'compose) - '(compose '1+ - (lambda (x) - (* x 2)) - #'read-from-string) - nil))) - (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) - (funcall fun "3"))) - 7) - -(deftest compose.4 - (let ((composite (compose #'zerop))) - (list (funcall composite 0) - (funcall composite 1))) - (t nil)) - -(deftest multiple-value-compose.1 - (let ((composite (multiple-value-compose - #'truncate - (lambda (x y) - (values y x)) - (lambda (x) - (with-input-from-string (s x) - (values (read s) (read s))))))) - (multiple-value-list (funcall composite "2 7"))) - (3 1)) - -(deftest multiple-value-compose.2 - (let ((composite (locally (declare (notinline multiple-value-compose)) - (multiple-value-compose - #'truncate - (lambda (x y) - (values y x)) - (lambda (x) - (with-input-from-string (s x) - (values (read s) (read s)))))))) - (multiple-value-list (funcall composite "2 11"))) - (5 1)) - -(deftest multiple-value-compose.3 - (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose) - '(multiple-value-compose - #'truncate - (lambda (x y) - (values y x)) - (lambda (x) - (with-input-from-string (s x) - (values (read s) (read s))))) - nil))) - (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) - (multiple-value-list (funcall fun "2 9")))) - (4 1)) - -(deftest multiple-value-compose.4 - (let ((composite (multiple-value-compose #'truncate))) - (multiple-value-list (funcall composite 9 2))) - (4 1)) - -(deftest curry.1 - (let ((curried (curry '+ 3))) - (funcall curried 1 5)) - 9) - -(deftest curry.2 - (let ((curried (locally (declare (notinline curry)) - (curry '* 2 3)))) - (funcall curried 7)) - 42) - -(deftest curry.3 - (let ((curried-form (funcall (compiler-macro-function 'curry) - '(curry '/ 8) - nil))) - (let ((fun (funcall (compile nil `(lambda () ,curried-form))))) - (funcall fun 2))) - 4) - -(deftest curry.4 - (let* ((x 1) - (curried (curry (progn - (incf x) - (lambda (y z) (* x y z))) - 3))) - (list (funcall curried 7) - (funcall curried 7) - x)) - (42 42 2)) - -(deftest rcurry.1 - (let ((r (rcurry '/ 2))) - (funcall r 8)) - 4) - -(deftest rcurry.2 - (let* ((x 1) - (curried (rcurry (progn - (incf x) - (lambda (y z) (* x y z))) - 3))) - (list (funcall curried 7) - (funcall curried 7) - x)) - (42 42 2)) - -(deftest named-lambda.1 - (let ((fac (named-lambda fac (x) - (if (> x 1) - (* x (fac (- x 1))) - x)))) - (funcall fac 5)) - 120) - -(deftest named-lambda.2 - (let ((fac (named-lambda fac (&key x) - (if (> x 1) - (* x (fac :x (- x 1))) - x)))) - (funcall fac :x 5)) - 120) - -;;;; Lists - -(deftest alist-plist.1 - (alist-plist '((a . 1) (b . 2) (c . 3))) - (a 1 b 2 c 3)) - -(deftest plist-alist.1 - (plist-alist '(a 1 b 2 c 3)) - ((a . 1) (b . 2) (c . 3))) - -(deftest unionf.1 - (let* ((list (list 1 2 3)) - (orig list)) - (unionf list (list 1 2 4)) - (values (equal orig (list 1 2 3)) - (eql (length list) 4) - (set-difference list (list 1 2 3 4)) - (set-difference (list 1 2 3 4) list))) - t - t - nil - nil) - -(deftest nunionf.1 - (let ((list (list 1 2 3))) - (nunionf list (list 1 2 4)) - (values (eql (length list) 4) - (set-difference (list 1 2 3 4) list) - (set-difference list (list 1 2 3 4)))) - t - nil - nil) - -(deftest appendf.1 - (let* ((list (list 1 2 3)) - (orig list)) - (appendf list '(4 5 6) '(7 8)) - (list list (eq list orig))) - ((1 2 3 4 5 6 7 8) nil)) - -(deftest nconcf.1 - (let ((list1 (list 1 2 3)) - (list2 (list 4 5 6))) - (nconcf list1 list2 (list 7 8 9)) - list1) - (1 2 3 4 5 6 7 8 9)) - -(deftest circular-list.1 - (let ((circle (circular-list 1 2 3))) - (list (first circle) - (second circle) - (third circle) - (fourth circle) - (eq circle (nthcdr 3 circle)))) - (1 2 3 1 t)) - -(deftest circular-list-p.1 - (let* ((circle (circular-list 1 2 3 4)) - (tree (list circle circle)) - (dotted (cons circle t)) - (proper (list 1 2 3 circle)) - (tailcirc (list* 1 2 3 circle))) - (list (circular-list-p circle) - (circular-list-p tree) - (circular-list-p dotted) - (circular-list-p proper) - (circular-list-p tailcirc))) - (t nil nil nil t)) - -(deftest circular-list-p.2 - (circular-list-p 'foo) - nil) - -(deftest circular-tree-p.1 - (let* ((circle (circular-list 1 2 3 4)) - (tree1 (list circle circle)) - (tree2 (let* ((level2 (list 1 nil 2)) - (level1 (list level2))) - (setf (second level2) level1) - level1)) - (dotted (cons circle t)) - (proper (list 1 2 3 circle)) - (tailcirc (list* 1 2 3 circle)) - (quite-proper (list 1 2 3)) - (quite-dotted (list 1 (cons 2 3)))) - (list (circular-tree-p circle) - (circular-tree-p tree1) - (circular-tree-p tree2) - (circular-tree-p dotted) - (circular-tree-p proper) - (circular-tree-p tailcirc) - (circular-tree-p quite-proper) - (circular-tree-p quite-dotted))) - (t t t t t t nil nil)) - -(deftest circular-tree-p.2 - (alexandria:circular-tree-p '#1=(#1#)) - t) - -(deftest proper-list-p.1 - (let ((l1 (list 1)) - (l2 (list 1 2)) - (l3 (cons 1 2)) - (l4 (list (cons 1 2) 3)) - (l5 (circular-list 1 2))) - (list (proper-list-p l1) - (proper-list-p l2) - (proper-list-p l3) - (proper-list-p l4) - (proper-list-p l5))) - (t t nil t nil)) - -(deftest proper-list-p.2 - (proper-list-p '(1 2 . 3)) - nil) - -(deftest proper-list.type.1 - (let ((l1 (list 1)) - (l2 (list 1 2)) - (l3 (cons 1 2)) - (l4 (list (cons 1 2) 3)) - (l5 (circular-list 1 2))) - (list (typep l1 'proper-list) - (typep l2 'proper-list) - (typep l3 'proper-list) - (typep l4 'proper-list) - (typep l5 'proper-list))) - (t t nil t nil)) - -(deftest proper-list-length.1 - (values - (proper-list-length nil) - (proper-list-length (list 1)) - (proper-list-length (list 2 2)) - (proper-list-length (list 3 3 3)) - (proper-list-length (list 4 4 4 4)) - (proper-list-length (list 5 5 5 5 5)) - (proper-list-length (list 6 6 6 6 6 6)) - (proper-list-length (list 7 7 7 7 7 7 7)) - (proper-list-length (list 8 8 8 8 8 8 8 8)) - (proper-list-length (list 9 9 9 9 9 9 9 9 9))) - 0 1 2 3 4 5 6 7 8 9) - -(deftest proper-list-length.2 - (flet ((plength (x) - (handler-case - (proper-list-length x) - (type-error () - :ok)))) - (values - (plength (list* 1)) - (plength (list* 2 2)) - (plength (list* 3 3 3)) - (plength (list* 4 4 4 4)) - (plength (list* 5 5 5 5 5)) - (plength (list* 6 6 6 6 6 6)) - (plength (list* 7 7 7 7 7 7 7)) - (plength (list* 8 8 8 8 8 8 8 8)) - (plength (list* 9 9 9 9 9 9 9 9 9)))) - :ok :ok :ok - :ok :ok :ok - :ok :ok :ok) - -(deftest lastcar.1 - (let ((l1 (list 1)) - (l2 (list 1 2))) - (list (lastcar l1) - (lastcar l2))) - (1 2)) - -(deftest lastcar.error.2 - (handler-case - (progn - (lastcar (circular-list 1 2 3)) - nil) - (error () - t)) - t) - -(deftest setf-lastcar.1 - (let ((l (list 1 2 3 4))) - (values (lastcar l) - (progn - (setf (lastcar l) 42) - (lastcar l)))) - 4 - 42) - -(deftest setf-lastcar.2 - (let ((l (circular-list 1 2 3))) - (multiple-value-bind (res err) - (ignore-errors (setf (lastcar l) 4)) - (typep err 'type-error))) - t) - -(deftest make-circular-list.1 - (let ((l (make-circular-list 3 :initial-element :x))) - (setf (car l) :y) - (list (eq l (nthcdr 3 l)) - (first l) - (second l) - (third l) - (fourth l))) - (t :y :x :x :y)) - -(deftest circular-list.type.1 - (let* ((l1 (list 1 2 3)) - (l2 (circular-list 1 2 3)) - (l3 (list* 1 2 3 l2))) - (list (typep l1 'circular-list) - (typep l2 'circular-list) - (typep l3 'circular-list))) - (nil t t)) - -(deftest ensure-list.1 - (let ((x (list 1)) - (y 2)) - (list (ensure-list x) - (ensure-list y))) - ((1) (2))) - -(deftest ensure-cons.1 - (let ((x (cons 1 2)) - (y nil) - (z "foo")) - (values (ensure-cons x) - (ensure-cons y) - (ensure-cons z))) - (1 . 2) - (nil) - ("foo")) - -(deftest setp.1 - (setp '(1)) - t) - -(deftest setp.2 - (setp nil) - t) - -(deftest setp.3 - (setp "foo") - nil) - -(deftest setp.4 - (setp '(1 2 3 1)) - nil) - -(deftest setp.5 - (setp '(1 2 3)) - t) - -(deftest setp.6 - (setp '(a :a)) - t) - -(deftest setp.7 - (setp '(a :a) :key 'character) - nil) - -(deftest setp.8 - (setp '(a :a) :key 'character :test (constantly nil)) - t) - -(deftest set-equal.1 - (set-equal '(1 2 3) '(3 1 2)) - t) - -(deftest set-equal.2 - (set-equal '("Xa") '("Xb") - :test (lambda (a b) (eql (char a 0) (char b 0)))) - t) - -(deftest set-equal.3 - (set-equal '(1 2) '(4 2)) - nil) - -(deftest set-equal.4 - (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal) - t) - -(deftest set-equal.5 - (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal) - nil) - -(deftest set-equal.6 - (set-equal '(a b c) '(a b c d)) - nil) - -(deftest map-product.1 - (map-product 'cons '(2 3) '(1 4)) - ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) - -(deftest map-product.2 - (map-product #'cons '(2 3) '(1 4)) - ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) - -(deftest flatten.1 - (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7)) - (1 2 3 4 5 6 7)) - -(deftest remove-from-plist.1 - (let ((orig '(a 1 b 2 c 3 d 4))) - (list (remove-from-plist orig 'a 'c) - (remove-from-plist orig 'b 'd) - (remove-from-plist orig 'b) - (remove-from-plist orig 'a) - (remove-from-plist orig 'd 42 "zot") - (remove-from-plist orig 'a 'b 'c 'd) - (remove-from-plist orig 'a 'b 'c 'd 'x) - (equal orig '(a 1 b 2 c 3 d 4)))) - ((b 2 d 4) - (a 1 c 3) - (a 1 c 3 d 4) - (b 2 c 3 d 4) - (a 1 b 2 c 3) - nil - nil - t)) - -(deftest delete-from-plist.1 - (let ((orig '(a 1 b 2 c 3 d 4 d 5))) - (list (delete-from-plist (copy-list orig) 'a 'c) - (delete-from-plist (copy-list orig) 'b 'd) - (delete-from-plist (copy-list orig) 'b) - (delete-from-plist (copy-list orig) 'a) - (delete-from-plist (copy-list orig) 'd 42 "zot") - (delete-from-plist (copy-list orig) 'a 'b 'c 'd) - (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x) - (equal orig (delete-from-plist orig)) - (eq orig (delete-from-plist orig)))) - ((b 2 d 4 d 5) - (a 1 c 3) - (a 1 c 3 d 4 d 5) - (b 2 c 3 d 4 d 5) - (a 1 b 2 c 3) - nil - nil - t - t)) - -(deftest mappend.1 - (mappend (compose 'list '*) '(1 2 3) '(1 2 3)) - (1 4 9)) - -(deftest assoc-value.1 - (let ((key1 '(complex key)) - (key2 'simple-key) - (alist '()) - (result '())) - (push 1 (assoc-value alist key1 :test #'equal)) - (push 2 (assoc-value alist key1 :test 'equal)) - (push 42 (assoc-value alist key2)) - (push 43 (assoc-value alist key2 :test 'eq)) - (push (assoc-value alist key1 :test #'equal) result) - (push (assoc-value alist key2) result) - - (push 'very (rassoc-value alist (list 2 1) :test #'equal)) - (push (cdr (assoc '(very complex key) alist :test #'equal)) result) - result) - ((2 1) (43 42) (2 1))) - -;;;; Numbers - -(deftest clamp.1 - (list (clamp 1.5 1 2) - (clamp 2.0 1 2) - (clamp 1.0 1 2) - (clamp 3 1 2) - (clamp 0 1 2)) - (1.5 2.0 1.0 2 1)) - -(deftest gaussian-random.1 - (let ((min -0.2) - (max +0.2)) - (multiple-value-bind (g1 g2) - (gaussian-random min max) - (values (<= min g1 max) - (<= min g2 max) - (/= g1 g2) ;uh - ))) - t - t - t) - -#+sbcl -(deftest gaussian-random.2 - (handler-case - (sb-ext:with-timeout 2 - (progn - (loop - :repeat 10000 - :do (gaussian-random 0 nil)) - 'done)) - (sb-ext:timeout () - 'timed-out)) - done) - -(deftest iota.1 - (iota 3) - (0 1 2)) - -(deftest iota.2 - (iota 3 :start 0.0d0) - (0.0d0 1.0d0 2.0d0)) - -(deftest iota.3 - (iota 3 :start 2 :step 3.0) - (2.0 5.0 8.0)) - -(deftest map-iota.1 - (let (all) - (declare (notinline map-iota)) - (values (map-iota (lambda (x) (push x all)) - 3 - :start 2 - :step 1.1d0) - all)) - 3 - (4.2d0 3.1d0 2.0d0)) - -(deftest lerp.1 - (lerp 0.5 1 2) - 1.5) - -(deftest lerp.2 - (lerp 0.1 1 2) - 1.1) - -(deftest lerp.3 - (lerp 0.1 4 25) - 6.1) - -(deftest mean.1 - (mean '(1 2 3)) - 2) - -(deftest mean.2 - (mean '(1 2 3 4)) - 5/2) - -(deftest mean.3 - (mean '(1 2 10)) - 13/3) - -(deftest median.1 - (median '(100 0 99 1 98 2 97)) - 97) - -(deftest median.2 - (median '(100 0 99 1 98 2 97 96)) - 193/2) - -(deftest variance.1 - (variance (list 1 2 3)) - 2/3) - -(deftest standard-deviation.1 - (< 0 (standard-deviation (list 1 2 3)) 1) - t) - -(deftest maxf.1 - (let ((x 1)) - (maxf x 2) - x) - 2) - -(deftest maxf.2 - (let ((x 1)) - (maxf x 0) - x) - 1) - -(deftest maxf.3 - (let ((x 1) - (c 0)) - (maxf x (incf c)) - (list x c)) - (1 1)) - -(deftest maxf.4 - (let ((xv (vector 0 0 0)) - (p 0)) - (maxf (svref xv (incf p)) (incf p)) - (list p xv)) - (2 #(0 2 0))) - -(deftest minf.1 - (let ((y 1)) - (minf y 0) - y) - 0) - -(deftest minf.2 - (let ((xv (vector 10 10 10)) - (p 0)) - (minf (svref xv (incf p)) (incf p)) - (list p xv)) - (2 #(10 2 10))) - -(deftest subfactorial.1 - (mapcar #'subfactorial (iota 22)) - (1 - 0 - 1 - 2 - 9 - 44 - 265 - 1854 - 14833 - 133496 - 1334961 - 14684570 - 176214841 - 2290792932 - 32071101049 - 481066515734 - 7697064251745 - 130850092279664 - 2355301661033953 - 44750731559645106 - 895014631192902121 - 18795307255050944540)) - -;;;; Arrays - -#+nil -(deftest array-index.type) - -#+nil -(deftest copy-array) - -;;;; Sequences - -(deftest rotate.1 - (list (rotate (list 1 2 3) 0) - (rotate (list 1 2 3) 1) - (rotate (list 1 2 3) 2) - (rotate (list 1 2 3) 3) - (rotate (list 1 2 3) 4)) - ((1 2 3) - (3 1 2) - (2 3 1) - (1 2 3) - (3 1 2))) - -(deftest rotate.2 - (list (rotate (vector 1 2 3 4) 0) - (rotate (vector 1 2 3 4)) - (rotate (vector 1 2 3 4) 2) - (rotate (vector 1 2 3 4) 3) - (rotate (vector 1 2 3 4) 4) - (rotate (vector 1 2 3 4) 5)) - (#(1 2 3 4) - #(4 1 2 3) - #(3 4 1 2) - #(2 3 4 1) - #(1 2 3 4) - #(4 1 2 3))) - -(deftest rotate.3 - (list (rotate (list 1 2 3) 0) - (rotate (list 1 2 3) -1) - (rotate (list 1 2 3) -2) - (rotate (list 1 2 3) -3) - (rotate (list 1 2 3) -4)) - ((1 2 3) - (2 3 1) - (3 1 2) - (1 2 3) - (2 3 1))) - -(deftest rotate.4 - (list (rotate (vector 1 2 3 4) 0) - (rotate (vector 1 2 3 4) -1) - (rotate (vector 1 2 3 4) -2) - (rotate (vector 1 2 3 4) -3) - (rotate (vector 1 2 3 4) -4) - (rotate (vector 1 2 3 4) -5)) - (#(1 2 3 4) - #(2 3 4 1) - #(3 4 1 2) - #(4 1 2 3) - #(1 2 3 4) - #(2 3 4 1))) - -(deftest rotate.5 - (values (rotate (list 1) 17) - (rotate (list 1) -5)) - (1) - (1)) - -(deftest shuffle.1 - (let ((s (shuffle (iota 100)))) - (list (equal s (iota 100)) - (every (lambda (x) - (member x s)) - (iota 100)) - (every (lambda (x) - (typep x '(integer 0 99))) - s))) - (nil t t)) - -(deftest shuffle.2 - (let ((s (shuffle (coerce (iota 100) 'vector)))) - (list (equal s (coerce (iota 100) 'vector)) - (every (lambda (x) - (find x s)) - (iota 100)) - (every (lambda (x) - (typep x '(integer 0 99))) - s))) - (nil t t)) - -(deftest shuffle.3 - (let* ((orig (coerce (iota 21) 'vector)) - (copy (copy-seq orig))) - (shuffle copy :start 10 :end 15) - (list (every #'eql (subseq copy 0 10) (subseq orig 0 10)) - (every #'eql (subseq copy 15) (subseq orig 15)))) - (t t)) - -(deftest random-elt.1 - (let ((s1 #(1 2 3 4)) - (s2 '(1 2 3 4))) - (list (dotimes (i 1000 nil) - (unless (member (random-elt s1) s2) - (return nil)) - (when (/= (random-elt s1) (random-elt s1)) - (return t))) - (dotimes (i 1000 nil) - (unless (member (random-elt s2) s2) - (return nil)) - (when (/= (random-elt s2) (random-elt s2)) - (return t))))) - (t t)) - -(deftest removef.1 - (let* ((x '(1 2 3)) - (x* x) - (y #(1 2 3)) - (y* y)) - (removef x 1) - (removef y 3) - (list x x* y y*)) - ((2 3) - (1 2 3) - #(1 2) - #(1 2 3))) - -(deftest deletef.1 - (let* ((x (list 1 2 3)) - (x* x) - (y (vector 1 2 3))) - (deletef x 2) - (deletef y 1) - (list x x* y)) - ((1 3) - (1 3) - #(2 3))) - -(deftest map-permutations.1 - (let ((seq (list 1 2 3)) - (seen nil) - (ok t)) - (map-permutations (lambda (s) - (unless (set-equal s seq) - (setf ok nil)) - (when (member s seen :test 'equal) - (setf ok nil)) - (push s seen)) - seq - :copy t) - (values ok (length seen))) - t - 6) - -(deftest proper-sequence.type.1 - (mapcar (lambda (x) - (typep x 'proper-sequence)) - (list (list 1 2 3) - (vector 1 2 3) - #2a((1 2) (3 4)) - (circular-list 1 2 3 4))) - (t t nil nil)) - -(deftest emptyp.1 - (mapcar #'emptyp - (list (list 1) - (circular-list 1) - nil - (vector) - (vector 1))) - (nil nil t t nil)) - -(deftest sequence-of-length-p.1 - (mapcar #'sequence-of-length-p - (list nil - #() - (list 1) - (vector 1) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2)) - (list 0 - 0 - 1 - 1 - 2 - 2 - 1 - 1 - 4 - 4)) - (t t t t t t nil nil nil nil)) - -(deftest length=.1 - (mapcar #'length= - (list nil - #() - (list 1) - (vector 1) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2)) - (list 0 - 0 - 1 - 1 - 2 - 2 - 1 - 1 - 4 - 4)) - (t t t t t t nil nil nil nil)) - -(deftest length=.2 - ;; test the compiler macro - (macrolet ((x (&rest args) - (funcall - (compile nil - `(lambda () - (length= ,@args)))))) - (list (x 2 '(1 2)) - (x '(1 2) '(3 4)) - (x '(1 2) 2) - (x '(1 2) 2 '(3 4)) - (x 1 2 3))) - (t t t t nil)) - -(deftest copy-sequence.1 - (let ((l (list 1 2 3)) - (v (vector #\a #\b #\c))) - (declare (notinline copy-sequence)) - (let ((l.list (copy-sequence 'list l)) - (l.vector (copy-sequence 'vector l)) - (l.spec-v (copy-sequence '(vector fixnum) l)) - (v.vector (copy-sequence 'vector v)) - (v.list (copy-sequence 'list v)) - (v.string (copy-sequence 'string v))) - (list (member l (list l.list l.vector l.spec-v)) - (member v (list v.vector v.list v.string)) - (equal l.list l) - (equalp l.vector #(1 2 3)) - (type= (upgraded-array-element-type 'fixnum) - (array-element-type l.spec-v)) - (equalp v.vector v) - (equal v.list '(#\a #\b #\c)) - (equal "abc" v.string)))) - (nil nil t t t t t t)) - -(deftest first-elt.1 - (mapcar #'first-elt - (list (list 1 2 3) - "abc" - (vector :a :b :c))) - (1 #\a :a)) - -(deftest first-elt.error.1 - (mapcar (lambda (x) - (handler-case - (first-elt x) - (type-error () - :type-error))) - (list nil - #() - 12 - :zot)) - (:type-error - :type-error - :type-error - :type-error)) - -(deftest setf-first-elt.1 - (let ((l (list 1 2 3)) - (s (copy-seq "foobar")) - (v (vector :a :b :c))) - (setf (first-elt l) -1 - (first-elt s) #\x - (first-elt v) 'zot) - (values l s v)) - (-1 2 3) - "xoobar" - #(zot :b :c)) - -(deftest setf-first-elt.error.1 - (let ((l 'foo)) - (multiple-value-bind (res err) - (ignore-errors (setf (first-elt l) 4)) - (typep err 'type-error))) - t) - -(deftest last-elt.1 - (mapcar #'last-elt - (list (list 1 2 3) - (vector :a :b :c) - "FOOBAR" - #*001 - #*010)) - (3 :c #\R 1 0)) - -(deftest last-elt.error.1 - (mapcar (lambda (x) - (handler-case - (last-elt x) - (type-error () - :type-error))) - (list nil - #() - 12 - :zot - (circular-list 1 2 3) - (list* 1 2 3 (circular-list 4 5)))) - (:type-error - :type-error - :type-error - :type-error - :type-error - :type-error)) - -(deftest setf-last-elt.1 - (let ((l (list 1 2 3)) - (s (copy-seq "foobar")) - (b (copy-seq #*010101001))) - (setf (last-elt l) '??? - (last-elt s) #\? - (last-elt b) 0) - (values l s b)) - (1 2 ???) - "fooba?" - #*010101000) - -(deftest setf-last-elt.error.1 - (handler-case - (setf (last-elt 'foo) 13) - (type-error () - :type-error)) - :type-error) - -(deftest starts-with.1 - (list (starts-with 1 '(1 2 3)) - (starts-with 1 #(1 2 3)) - (starts-with #\x "xyz") - (starts-with 2 '(1 2 3)) - (starts-with 3 #(1 2 3)) - (starts-with 1 1) - (starts-with nil nil)) - (t t t nil nil nil nil)) - -(deftest starts-with.2 - (values (starts-with 1 '(-1 2 3) :key '-) - (starts-with "foo" '("foo" "bar") :test 'equal) - (starts-with "f" '(#\f) :key 'string :test 'equal) - (starts-with -1 '(0 1 2) :key #'1+) - (starts-with "zot" '("ZOT") :test 'equal)) - t - t - t - nil - nil) - -(deftest ends-with.1 - (list (ends-with 3 '(1 2 3)) - (ends-with 3 #(1 2 3)) - (ends-with #\z "xyz") - (ends-with 2 '(1 2 3)) - (ends-with 1 #(1 2 3)) - (ends-with 1 1) - (ends-with nil nil)) - (t t t nil nil nil nil)) - -(deftest ends-with.2 - (values (ends-with 2 '(0 13 1) :key '1+) - (ends-with "foo" (vector "bar" "foo") :test 'equal) - (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal) - (ends-with "foo" "foo" :test 'equal)) - t - t - t - nil) - -(deftest ends-with.error.1 - (handler-case - (ends-with 3 (circular-list 3 3 3 1 3 3)) - (type-error () - :type-error)) - :type-error) - -(deftest sequences.passing-improper-lists - (macrolet ((signals-error-p (form) - `(handler-case - (progn ,form nil) - (type-error (e) - t))) - (cut (fn &rest args) - (with-gensyms (arg) - (print`(lambda (,arg) - (apply ,fn (list ,@(substitute arg '_ args)))))))) - (let ((circular-list (make-circular-list 5 :initial-element :foo)) - (dotted-list (list* 'a 'b 'c 'd))) - (loop for nth from 0 - for fn in (list - (cut #'lastcar _) - (cut #'rotate _ 3) - (cut #'rotate _ -3) - (cut #'shuffle _) - (cut #'random-elt _) - (cut #'last-elt _) - (cut #'ends-with :foo _)) - nconcing - (let ((on-circular-p (signals-error-p (funcall fn circular-list))) - (on-dotted-p (signals-error-p (funcall fn dotted-list)))) - (when (or (not on-circular-p) (not on-dotted-p)) - (append - (unless on-circular-p - (let ((*print-circle* t)) - (list - (format nil - "No appropriate error signalled when passing ~S to ~Ath entry." - circular-list nth)))) - (unless on-dotted-p - (list - (format nil - "No appropriate error signalled when passing ~S to ~Ath entry." - dotted-list nth))))))))) - nil) - -;;;; IO - -(deftest read-stream-content-into-string.1 - (values (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream)) - (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream :buffer-size 1)) - (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream :buffer-size 6)) - (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream :buffer-size 7))) - "foo bar" - "foo bar" - "foo bar" - "foo bar") - -(deftest read-stream-content-into-string.2 - (handler-case - (let ((stream (make-broadcast-stream))) - (read-stream-content-into-string stream :buffer-size 0)) - (type-error () - :type-error)) - :type-error) - -#+(or) -(defvar *octets* - (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar")) - -#+(or) -(deftest read-stream-content-into-byte-vector.1 - (values (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream)) - (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream :initial-size 1)) - (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream 'alexandria::%length 6)) - (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream 'alexandria::%length 3))) - *octets* - *octets* - *octets* - (subseq *octets* 0 3)) - -(deftest read-stream-content-into-byte-vector.2 - (handler-case - (let ((stream (make-broadcast-stream))) - (read-stream-content-into-byte-vector stream :initial-size 0)) - (type-error () - :type-error)) - :type-error) - -;;;; Macros - -(deftest with-unique-names.1 - (let ((*gensym-counter* 0)) - (let ((syms (with-unique-names (foo bar quux) - (list foo bar quux)))) - (list (find-if #'symbol-package syms) - (equal '("FOO0" "BAR1" "QUUX2") - (mapcar #'symbol-name syms))))) - (nil t)) - -(deftest with-unique-names.2 - (let ((*gensym-counter* 0)) - (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q)) - (list foo bar quux)))) - (list (find-if #'symbol-package syms) - (equal '("_foo_0" "-BAR-1" "q2") - (mapcar #'symbol-name syms))))) - (nil t)) - -(deftest with-unique-names.3 - (let ((*gensym-counter* 0)) - (multiple-value-bind (res err) - (ignore-errors - (eval - '(let ((syms - (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42)) - (list foo bar quux)))) - (list (find-if #'symbol-package syms) - (equal '("_foo_0" "-BAR-1" "q2") - (mapcar #'symbol-name syms)))))) - (errorp err))) - t) - -(deftest once-only.1 - (macrolet ((cons1.good (x) - (once-only (x) - `(cons ,x ,x))) - (cons1.bad (x) - `(cons ,x ,x))) - (let ((y 0)) - (list (cons1.good (incf y)) - y - (cons1.bad (incf y)) - y))) - ((1 . 1) 1 (2 . 3) 3)) - -(deftest once-only.2 - (macrolet ((cons1 (x) - (once-only ((y x)) - `(cons ,y ,y)))) - (let ((z 0)) - (list (cons1 (incf z)) - z - (cons1 (incf z))))) - ((1 . 1) 1 (2 . 2))) - -(deftest parse-body.1 - (parse-body '("doc" "body") :documentation t) - ("body") - nil - "doc") - -(deftest parse-body.2 - (parse-body '("body") :documentation t) - ("body") - nil - nil) - -(deftest parse-body.3 - (parse-body '("doc" "body")) - ("doc" "body") - nil - nil) - -(deftest parse-body.4 - (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t) - (body) - ((declare (foo)) (declare (bar))) - "doc") - -(deftest parse-body.5 - (parse-body '((declare (foo)) "doc" (declare (bar)) body)) - ("doc" (declare (bar)) body) - ((declare (foo))) - nil) - -(deftest parse-body.6 - (multiple-value-bind (res err) - (ignore-errors - (parse-body '("foo" "bar" "quux") - :documentation t)) - (errorp err)) - t) - -;;;; Symbols - -(deftest ensure-symbol.1 - (ensure-symbol :cons :cl) - cons - :external) - -(deftest ensure-symbol.2 - (ensure-symbol "CONS" :alexandria) - cons - :inherited) - -(deftest ensure-symbol.3 - (ensure-symbol 'foo :keyword) - :foo - :external) - -(deftest ensure-symbol.4 - (ensure-symbol #\* :alexandria) - * - :inherited) - -(deftest format-symbol.1 - (let ((s (format-symbol nil '#:x-~d 13))) - (list (symbol-package s) - (string= (string '#:x-13) (symbol-name s)))) - (nil t)) - -(deftest format-symbol.2 - (format-symbol :keyword '#:sym-~a (string :bolic)) - :sym-bolic) - -(deftest format-symbol.3 - (let ((*package* (find-package :cl))) - (format-symbol t '#:find-~a (string 'package))) - find-package) - -(deftest make-keyword.1 - (list (make-keyword 'zot) - (make-keyword "FOO") - (make-keyword #\Q)) - (:zot :foo :q)) - -(deftest make-gensym-list.1 - (let ((*gensym-counter* 0)) - (let ((syms (make-gensym-list 3 "FOO"))) - (list (find-if 'symbol-package syms) - (equal '("FOO0" "FOO1" "FOO2") - (mapcar 'symbol-name syms))))) - (nil t)) - -(deftest make-gensym-list.2 - (let ((*gensym-counter* 0)) - (let ((syms (make-gensym-list 3))) - (list (find-if 'symbol-package syms) - (equal '("G0" "G1" "G2") - (mapcar 'symbol-name syms))))) - (nil t)) - -;;;; Type-system - -(deftest of-type.1 - (locally - (declare (notinline of-type)) - (let ((f (of-type 'string))) - (list (funcall f "foo") - (funcall f 'bar)))) - (t nil)) - -(deftest type=.1 - (type= 'string 'string) - t - t) - -(deftest type=.2 - (type= 'list '(or null cons)) - t - t) - -(deftest type=.3 - (type= 'null '(and symbol list)) - t - t) - -(deftest type=.4 - (type= 'string '(satisfies emptyp)) - nil - nil) - -(deftest type=.5 - (type= 'string 'list) - nil - t) - -(macrolet - ((test (type numbers) - `(deftest ,(format-symbol t '#:cdr5.~a (string type)) - (let ((numbers ,numbers)) - (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers) - (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers) - (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers) - (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers))) - (t t t nil nil nil nil) - (t t t t nil nil nil) - (nil nil nil t t t t) - (nil nil nil nil t t t)))) - (test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum)) - (test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum))) - (test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum))) - (test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float)) - (test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float)) - (test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float)) - (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float)) - (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float)) - (test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float))) - -;;;; Bindings - -(declaim (notinline opaque)) -(defun opaque (x) - x) - -(deftest if-let.1 - (if-let (x (opaque :ok)) - x - :bad) - :ok) - -(deftest if-let.2 - (if-let (x (opaque nil)) - :bad - (and (not x) :ok)) - :ok) - -(deftest if-let.3 - (let ((x 1)) - (if-let ((x 2) - (y x)) - (+ x y) - :oops)) - 3) - -(deftest if-let.4 - (if-let ((x 1) - (y nil)) - :oops - (and (not y) x)) - 1) - -(deftest if-let.5 - (if-let (x) - :oops - (not x)) - t) - -(deftest if-let.error.1 - (handler-case - (eval '(if-let x - :oops - :oops)) - (type-error () - :type-error)) - :type-error) - -(deftest when-let.1 - (when-let (x (opaque :ok)) - (setf x (cons x x)) - x) - (:ok . :ok)) - -(deftest when-let.2 - (when-let ((x 1) - (y nil) - (z 3)) - :oops) - nil) - -(deftest when-let.3 - (let ((x 1)) - (when-let ((x 2) - (y x)) - (+ x y))) - 3) - -(deftest when-let.error.1 - (handler-case - (eval '(when-let x :oops)) - (type-error () - :type-error)) - :type-error) - -(deftest when-let*.1 - (let ((x 1)) - (when-let* ((x 2) - (y x)) - (+ x y))) - 4) - -(deftest when-let*.2 - (let ((y 1)) - (when-let* (x y) - (1+ x))) - 2) - -(deftest when-let*.3 - (when-let* ((x t) - (y (consp x)) - (z (error "OOPS"))) - t) - nil) - -(deftest when-let*.error.1 - (handler-case - (eval '(when-let* x :oops)) - (type-error () - :type-error)) - :type-error) - -(deftest doplist.1 - (let (keys values) - (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v)) - (push k keys) - (push v values))) - t - (a b c) - (1 2 3) - nil - nil) - -(deftest count-permutations.1 - (values (count-permutations 31 7) - (count-permutations 1 1) - (count-permutations 2 1) - (count-permutations 2 2) - (count-permutations 3 2) - (count-permutations 3 1)) - 13253058000 - 1 - 2 - 2 - 6 - 3) - -(deftest binomial-coefficient.1 - (alexandria:binomial-coefficient 1239 139) - 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154) - -;; Exercise bignum case (at least on x86). -(deftest binomial-coefficient.2 - (alexandria:binomial-coefficient 2000000000000 20) - 430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000) - -(deftest copy-stream.1 - (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh")) - (values (equal data - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out)))) - (equal (subseq data 10 20) - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out :start 10 :end 20)))) - (equal (subseq data 10) - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out :start 10)))) - (equal (subseq data 0 20) - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out :end 20)))))) - t - t - t - t) - -(deftest extremum.1 - (let ((n 0)) - (dotimes (i 10) - (let ((data (shuffle (coerce (iota 10000 :start i) 'vector))) - (ok t)) - (unless (eql i (extremum data #'<)) - (setf ok nil)) - (unless (eql i (extremum (coerce data 'list) #'<)) - (setf ok nil)) - (unless (eql (+ 9999 i) (extremum data #'>)) - (setf ok nil)) - (unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>)) - (setf ok nil)) - (when ok - (incf n)))) - (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3)) - (incf n)) - (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs)) - (incf n)) - (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b)))) - (incf n)) - n) - 13) - -(deftest starts-with-subseq.string - (starts-with-subseq "f" "foo" :return-suffix t) - t - "oo") - -(deftest starts-with-subseq.vector - (starts-with-subseq #(1) #(1 2 3) :return-suffix t) - t - #(2 3)) - -(deftest starts-with-subseq.list - (starts-with-subseq '(1) '(1 2 3) :return-suffix t) - t - (2 3)) - -(deftest starts-with-subseq.start1 - (starts-with-subseq "foo" "oop" :start1 1) - t - nil) - -(deftest starts-with-subseq.start2 - (starts-with-subseq "foo" "xfoop" :start2 1) - t - nil) - -(deftest format-symbol.print-case-bound - (let ((upper (intern "FOO-BAR")) - (lower (intern "foo-bar")) - (*print-escape* nil)) - (values - (let ((*print-case* :downcase)) - (and (eq upper (format-symbol t "~A" upper)) - (eq lower (format-symbol t "~A" lower)))) - (let ((*print-case* :upcase)) - (and (eq upper (format-symbol t "~A" upper)) - (eq lower (format-symbol t "~A" lower)))) - (let ((*print-case* :capitalize)) - (and (eq upper (format-symbol t "~A" upper)) - (eq lower (format-symbol t "~A" lower)))))) - t - t - t) - -(deftest iota.fp-start-and-complex-integer-step - (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0)) - (iota 3 :start 0.0 :step #C(0 2))) - t) - -(deftest parse-ordinary-lambda-list.1 - (multiple-value-bind (req opt rest keys allowp aux keyp) - (parse-ordinary-lambda-list '(a b c - &optional o1 (o2 42) (o3 42 o3-supplied?) - &key (k1) ((:key k2)) (k3 42 k3-supplied?)) - :normalize t) - (and (equal '(a b c) req) - (equal '((o1 nil nil) - (o2 42 nil) - (o3 42 o3-supplied?)) - opt) - (equal '(((:k1 k1) nil nil) - ((:key k2) nil nil) - ((:k3 k3) 42 k3-supplied?)) - keys) - (not allowp) - (not aux) - (eq t keyp))) - t) diff --git a/third_party/lisp/alexandria/types.lisp b/third_party/lisp/alexandria/types.lisp deleted file mode 100644 index 1942d0ecdf..0000000000 --- a/third_party/lisp/alexandria/types.lisp +++ /dev/null @@ -1,137 +0,0 @@ -(in-package :alexandria) - -(deftype array-index (&optional (length (1- array-dimension-limit))) - "Type designator for an index into array of LENGTH: an integer between -0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than -ARRAY-DIMENSION-LIMIT." - `(integer 0 (,length))) - -(deftype array-length (&optional (length (1- array-dimension-limit))) - "Type designator for a dimension of an array of LENGTH: an integer between -0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than -ARRAY-DIMENSION-LIMIT." - `(integer 0 ,length)) - -;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/) -;; except the RATIO related definitions and ARRAY-INDEX. -(macrolet - ((frob (type &optional (base-type type)) - (let ((subtype-names (list)) - (predicate-names (list))) - (flet ((make-subtype-name (format-control) - (let ((result (format-symbol :alexandria format-control - (symbol-name type)))) - (push result subtype-names) - result)) - (make-predicate-name (sybtype-name) - (let ((result (format-symbol :alexandria '#:~A-p - (symbol-name sybtype-name)))) - (push result predicate-names) - result)) - (make-docstring (range-beg range-end range-type) - (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf")))) - (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A." - type - (if (equal range-beg ''*) inf (ensure-car range-beg)) - (if (equal range-end ''*) inf (ensure-car range-end)))))) - (let* ((negative-name (make-subtype-name '#:negative-~a)) - (non-positive-name (make-subtype-name '#:non-positive-~a)) - (non-negative-name (make-subtype-name '#:non-negative-~a)) - (positive-name (make-subtype-name '#:positive-~a)) - (negative-p-name (make-predicate-name negative-name)) - (non-positive-p-name (make-predicate-name non-positive-name)) - (non-negative-p-name (make-predicate-name non-negative-name)) - (positive-p-name (make-predicate-name positive-name)) - (negative-extremum) - (positive-extremum) - (below-zero) - (above-zero) - (zero)) - (setf (values negative-extremum below-zero - above-zero positive-extremum zero) - (ecase type - (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0)) - (integer (values ''* -1 1 ''* 0)) - (rational (values ''* '(0) '(0) ''* 0)) - (real (values ''* '(0) '(0) ''* 0)) - (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0)) - (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0)) - (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0)) - (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0)) - (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0)))) - `(progn - (deftype ,negative-name () - ,(make-docstring negative-extremum below-zero :negative) - `(,',base-type ,,negative-extremum ,',below-zero)) - - (deftype ,non-positive-name () - ,(make-docstring negative-extremum zero :negative) - `(,',base-type ,,negative-extremum ,',zero)) - - (deftype ,non-negative-name () - ,(make-docstring zero positive-extremum :positive) - `(,',base-type ,',zero ,,positive-extremum)) - - (deftype ,positive-name () - ,(make-docstring above-zero positive-extremum :positive) - `(,',base-type ,',above-zero ,,positive-extremum)) - - (declaim (inline ,@predicate-names)) - - (defun ,negative-p-name (n) - (and (typep n ',type) - (< n ,zero))) - - (defun ,non-positive-p-name (n) - (and (typep n ',type) - (<= n ,zero))) - - (defun ,non-negative-p-name (n) - (and (typep n ',type) - (<= ,zero n))) - - (defun ,positive-p-name (n) - (and (typep n ',type) - (< ,zero n))))))))) - (frob fixnum integer) - (frob integer) - (frob rational) - (frob real) - (frob float) - (frob short-float) - (frob single-float) - (frob double-float) - (frob long-float)) - -(defun of-type (type) - "Returns a function of one argument, which returns true when its argument is -of TYPE." - (lambda (thing) (typep thing type))) - -(define-compiler-macro of-type (&whole form type &environment env) - ;; This can yeild a big benefit, but no point inlining the function - ;; all over the place if TYPE is not constant. - (if (constantp type env) - (with-gensyms (thing) - `(lambda (,thing) - (typep ,thing ,type))) - form)) - -(declaim (inline type=)) -(defun type= (type1 type2) - "Returns a primary value of T is TYPE1 and TYPE2 are the same type, -and a secondary value that is true is the type equality could be reliably -determined: primary value of NIL and secondary value of T indicates that the -types are not equivalent." - (multiple-value-bind (sub ok) (subtypep type1 type2) - (cond ((and ok sub) - (subtypep type2 type1)) - (ok - (values nil ok)) - (t - (multiple-value-bind (sub ok) (subtypep type2 type1) - (declare (ignore sub)) - (values nil ok)))))) - -(define-modify-macro coercef (type-spec) coerce - "Modify-macro for COERCE.") diff --git a/third_party/lisp/anaphora.nix b/third_party/lisp/anaphora.nix index d2356f7b05..c079943e67 100644 --- a/third_party/lisp/anaphora.nix +++ b/third_party/lisp/anaphora.nix @@ -1,11 +1,6 @@ { depot, pkgs, ... }: -let src = pkgs.fetchFromGitHub { - owner = "tokenrove"; - repo = "anaphora"; - rev = "018590df36ffb30ece561fb28ea6521363efc6e2"; - sha256 = "0pq6y5swvrjd0kjs2dl2648s13s0pzxin0chrq35jam8jrci3kd1"; - }; +let src = with pkgs; srcOnly lispPackages.anaphora; in depot.nix.buildLisp.library { name = "anaphora"; diff --git a/third_party/lisp/babel.nix b/third_party/lisp/babel.nix index 7c066904fe..ae7c5dd23d 100644 --- a/third_party/lisp/babel.nix +++ b/third_party/lisp/babel.nix @@ -1,13 +1,13 @@ # Babel is an encoding conversion library for Common Lisp. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/cl-babel/babel.git"; - rev = "ec9a17cdbdba3c1dd39609fc7961cfb3f0aa260e"; -}; +let src = with pkgs; srcOnly lispPackages.babel; in depot.nix.buildLisp.library { name = "babel"; - deps = [ depot.third_party.lisp.alexandria ]; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.trivial-features + ]; srcs = map (f: src + ("/src/" + f)) [ "packages.lisp" diff --git a/third_party/lisp/bordeaux-threads.nix b/third_party/lisp/bordeaux-threads.nix index b2596672ba..8a2e099508 100644 --- a/third_party/lisp/bordeaux-threads.nix +++ b/third_party/lisp/bordeaux-threads.nix @@ -1,19 +1,24 @@ # This library is meant to make writing portable multi-threaded apps # in Common Lisp simple. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/sionescu/bordeaux-threads.git"; - rev = "499b6d3f0ce635417d6096acf0a671d8bf3f6e5f"; -}; -in depot.nix.buildLisp.library { +let + src = with pkgs; srcOnly lispPackages.bordeaux-threads; + getSrc = f: "${src}/src/${f}"; +in +depot.nix.buildLisp.library { name = "bordeaux-threads"; deps = [ depot.third_party.lisp.alexandria ]; - srcs = map (f: src + ("/src/" + f)) [ + srcs = map getSrc [ "pkgdcl.lisp" "bordeaux-threads.lisp" - "impl-sbcl.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 index 62c1f81da7..de1d0c2e8e 100644 --- a/third_party/lisp/cffi.nix +++ b/third_party/lisp/cffi.nix @@ -1,11 +1,8 @@ # CFFI purports to be the Common Foreign Function Interface. -{ depot, ... }: +{ depot, pkgs, ... }: with depot.nix; -let src = builtins.fetchGit { - url = "https://github.com/cffi/cffi.git"; - rev = "5e838bf46d0089c43ebd3ea014a207c403e29c61"; -}; +let src = with pkgs; srcOnly lispPackages.cffi; in buildLisp.library { name = "cffi"; deps = with depot.third_party.lisp; [ @@ -13,11 +10,15 @@ in buildLisp.library { babel trivial-features (buildLisp.bundled "asdf") - (buildLisp.bundled "uiop") ]; - srcs = map (f: src + ("/src/" + f)) [ - "cffi-sbcl.lisp" + 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" diff --git a/third_party/lisp/checkl.nix b/third_party/lisp/checkl.nix deleted file mode 100644 index 33c2330ecf..0000000000 --- a/third_party/lisp/checkl.nix +++ /dev/null @@ -1,26 +0,0 @@ -{ 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 pkgs.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 index dfbf32b094..59e9914ee1 100644 --- a/third_party/lisp/chipz.nix +++ b/third_party/lisp/chipz.nix @@ -1,17 +1,10 @@ # Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data -{ depot, ... }: +{ depot, pkgs, ... }: -with depot.nix; - -let src = depot.third_party.fetchFromGitHub { - owner = "froydnj"; - repo = "chipz"; - rev = "75dfbc660a5a28161c57f115adf74c8a926bfc4d"; - sha256 = "0plx4rs39zbs4gjk77h4a2q11zpy75fh9v8hnxrvsf8fnakajhwg"; -}; -in buildLisp.library { +let src = with pkgs; srcOnly lispPackages.chipz; +in depot.nix.buildLisp.library { name = "chipz"; - deps = [ (buildLisp.bundled "asdf") ]; + deps = [ (depot.nix.buildLisp.bundled "asdf") ]; srcs = map (f: src + ("/" + f)) [ "chipz.asd" diff --git a/third_party/lisp/chunga.nix b/third_party/lisp/chunga.nix index f787981887..d3f50bcb1a 100644 --- a/third_party/lisp/chunga.nix +++ b/third_party/lisp/chunga.nix @@ -1,12 +1,7 @@ # Portable chunked streams for Common Lisp -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "edicl"; - repo = "chunga"; - rev = "16330852d01dfde4dd97dee7cd985a88ea571e7e"; - sha256 = "0jzn3nyb3f22gm983rfk99smqs3mhb9ivjmasvhq9qla5cl9pyhd"; -}; +let src = with pkgs; srcOnly lispPackages.chunga; in depot.nix.buildLisp.library { name = "chunga"; deps = with depot.third_party.lisp; [ diff --git a/third_party/lisp/cl-ansi-text.nix b/third_party/lisp/cl-ansi-text.nix index 5c01e02326..0e34015247 100644 --- a/third_party/lisp/cl-ansi-text.nix +++ b/third_party/lisp/cl-ansi-text.nix @@ -1,10 +1,7 @@ # Enables ANSI colors for printing. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/pnathan/cl-ansi-text.git"; - rev = "257a5f19a2dc92d22f8fd772c0a78923b99b36a8"; -}; +let src = with pkgs; srcOnly lispPackages.cl-ansi-text; in depot.nix.buildLisp.library { name = "cl-ansi-text"; deps = with depot.third_party.lisp; [ diff --git a/third_party/lisp/cl-base64.nix b/third_party/lisp/cl-base64.nix index 1152601a81..08055a0471 100644 --- a/third_party/lisp/cl-base64.nix +++ b/third_party/lisp/cl-base64.nix @@ -1,10 +1,7 @@ # Base64 encoding for Common Lisp -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "http://git.kpe.io/cl-base64.git"; - rev = "fc62a5342445d4ec1dd44e95f7dc513473a8c89a"; -}; +let src = with pkgs; srcOnly lispPackages.cl-base64; in depot.nix.buildLisp.library { name = "cl-base64"; srcs = [ diff --git a/third_party/lisp/cl-change-case.nix b/third_party/lisp/cl-change-case.nix new file mode 100644 index 0000000000..b66368a9b6 --- /dev/null +++ b/third_party/lisp/cl-change-case.nix @@ -0,0 +1,22 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-change-case; +in depot.nix.buildLisp.library { + name = "cl-change-case"; + + deps = with depot.third_party.lisp; [ cl-ppcre cl-ppcre.unicode ]; + + srcs = [ (src + "/src/cl-change-case.lisp") ]; + + tests = { + name = "cl-change-case-tests"; + srcs = [ (src + "/t/cl-change-case.lisp") ]; + deps = [ + depot.third_party.lisp.fiveam + ]; + + expression = '' + (5am:run! :cl-change-case) + ''; + }; +} diff --git a/third_party/lisp/cl-colors.nix b/third_party/lisp/cl-colors.nix new file mode 100644 index 0000000000..b51e4d46a7 --- /dev/null +++ b/third_party/lisp/cl-colors.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-colors; +in depot.nix.buildLisp.library { + name = "cl-colors"; + deps = [ + depot.third_party.lisp.alexandria + depot.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 index c90b8eae01..34201bc2fa 100644 --- a/third_party/lisp/cl-colors2.nix +++ b/third_party/lisp/cl-colors2.nix @@ -1,10 +1,6 @@ +{ depot, pkgs, ... }: -{ depot, ... }: - -let src = builtins.fetchGit { - url = "https://notabug.org/cage/cl-colors2.git"; - rev = "795aedee593b095fecde574bd999b520dd03ed24"; -}; +let src = with pkgs; srcOnly lispPackages.cl-colors2; in depot.nix.buildLisp.library { name = "cl-colors2"; deps = with depot.third_party.lisp; [ @@ -15,7 +11,8 @@ in depot.nix.buildLisp.library { srcs = map (f: src + ("/" + f)) [ "package.lisp" "colors.lisp" - "colornames.lisp" + "colornames-x11.lisp" + "colornames-svg.lisp" "hexcolors.lisp" ]; } diff --git a/third_party/lisp/cl-date-time-parser.nix b/third_party/lisp/cl-date-time-parser.nix new file mode 100644 index 0000000000..e53cb2dfce --- /dev/null +++ b/third_party/lisp/cl-date-time-parser.nix @@ -0,0 +1,21 @@ +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "cl-date-time-parser"; + + srcs = [ + (pkgs.fetchurl { + url = "https://raw.githubusercontent.com/tkych/cl-date-time-parser/00d6fc70b599f460fdf13cf0cf7e6bf843312410/date-time-parser.lisp"; + sha256 = "0zrkv1q3sx5ksijxhw45ixf1hy5b9biii6i6v41h12q6pbkfqz69"; + }) + ]; + + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.anaphora + depot.third_party.lisp.split-sequence + depot.third_party.lisp.cl-ppcre + depot.third_party.lisp.local-time + depot.third_party.lisp.parse-float + ]; +} diff --git a/third_party/lisp/cl-fad.nix b/third_party/lisp/cl-fad.nix index 8131bf31be..9350abe2e3 100644 --- a/third_party/lisp/cl-fad.nix +++ b/third_party/lisp/cl-fad.nix @@ -1,25 +1,25 @@ # Portable pathname library -{ depot, ...}: +{ depot, pkgs, ... }: with depot.nix; -let src = depot.third_party.fetchFromGitHub { - owner = "edicl"; - repo = "cl-fad"; - rev = "c13d81c4bd9ba3a172631fd05dd213ab90e7d4cb"; - sha256 = "1gc8i82v6gks7g0lnm54r4prk2mklidv2flm5fvbr0a7rsys0vpa"; -}; +let src = with pkgs; srcOnly lispPackages.cl-fad; in buildLisp.library { name = "cl-fad"; deps = with depot.third_party.lisp; [ alexandria bordeaux-threads - (buildLisp.bundled "sb-posix") + { + 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 index 3652bd0793..6b82fac772 100644 --- a/third_party/lisp/cl-json.nix +++ b/third_party/lisp/cl-json.nix @@ -1,26 +1,53 @@ # JSON encoder & decoder -{ depot, ... }: +{ depot, pkgs, ... }: -with depot.nix; -let src = depot.third_party.fetchFromGitHub { - owner = "hankhero"; - repo = "cl-json"; - rev = "6dfebb9540bfc3cc33582d0c03c9ec27cb913e79"; - sha256 = "0fx3m3x3s5ji950yzpazz4s0img3l6b3d6l3jrfjv0lr702496lh"; -}; -in buildLisp.library { +let + inherit (depot.nix) buildLisp; + + # https://github.com/sharplispers/cl-json/pull/12/ + src = pkgs.fetchFromGitHub { + owner = "sternenseemann"; + repo = "cl-json"; + rev = "c059bec94e28a11102a994d6949e2e52764f21fd"; + sha256 = "0l07syw1b1x2zi8kj4iph3rf6vi6c16b7fk69iv7x27wrdsr1qwj"; + }; + + getSrcs = subdir: map (f: src + ("/" + subdir + "/" + f)); +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" - ]); + (getSrcs "src" [ + "package.lisp" + "common.lisp" + "objects.lisp" + "camel-case.lisp" + "decoder.lisp" + "encoder.lisp" + "utils.lisp" + "json-rpc.lisp" + ]); + + tests = { + deps = [ + depot.third_party.lisp.cl-unicode + depot.third_party.lisp.fiveam + ]; + srcs = [ + # CLOS tests are broken upstream as well + # https://github.com/sharplispers/cl-json/issues/11 + (pkgs.writeText "no-clos-tests.lisp" '' + (replace *features* (delete :cl-json-clos *features*)) + '') + ] ++ getSrcs "t" [ + "package.lisp" + "testencoder.lisp" + "testdecoder.lisp" + "testmisc.lisp" + ]; + + expression = "(fiveam:run! 'json-test::json)"; + }; } diff --git a/third_party/lisp/cl-plus-ssl.nix b/third_party/lisp/cl-plus-ssl.nix index 63c21aa6ba..dc0a95944f 100644 --- a/third_party/lisp/cl-plus-ssl.nix +++ b/third_party/lisp/cl-plus-ssl.nix @@ -1,13 +1,16 @@ # Common Lisp bindings to OpenSSL -{ depot, ... }: +{ 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 { +let + src = pkgs.fetchgit { + url = "https://github.com/cl-plus-ssl/cl-plus-ssl.git"; + rev = "29081992f6d7b4e3aa2c5eeece4cd92b745071f4"; + hash = "sha256:16lyrixl98b7vy29dbbzkbq0xaz789350dajrr1gdny5i55rkjq0"; + }; +in +buildLisp.library { name = "cl-plus-ssl"; deps = with depot.third_party.lisp; [ alexandria @@ -17,11 +20,14 @@ in buildLisp.library { trivial-features trivial-garbage trivial-gray-streams - (buildLisp.bundled "uiop") - (buildLisp.bundled "sb-posix") + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + { sbcl = buildLisp.bundled "sb-posix"; } ]; - native = [ depot.third_party.openssl ]; + native = [ pkgs.openssl ]; srcs = map (f: src + ("/src/" + f)) [ "package.lisp" @@ -37,4 +43,8 @@ in buildLisp.library { "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 index 1dc9eb5531..7cb99db639 100644 --- a/third_party/lisp/cl-ppcre.nix +++ b/third_party/lisp/cl-ppcre.nix @@ -1,10 +1,7 @@ # cl-ppcre is a Common Lisp regular expression library. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/edicl/cl-ppcre"; - rev = "1ca0cd9ca0d161acd49c463d6cb5fff897596e2f"; -}; +let src = with pkgs; srcOnly lispPackages.cl-ppcre; in depot.nix.buildLisp.library { name = "cl-ppcre"; @@ -27,4 +24,16 @@ in depot.nix.buildLisp.library { "scanner.lisp" "api.lisp" ]; + + passthru = { + unicode = depot.nix.buildLisp.library { + name = "cl-ppcre-unicode"; + deps = with depot.third_party.lisp; [ cl-ppcre cl-unicode ]; + + srcs = map (f: src + ("/cl-ppcre-unicode/" + f)) [ + "packages.lisp" + "resolver.lisp" + ]; + }; + }; } diff --git a/third_party/lisp/cl-prevalence.nix b/third_party/lisp/cl-prevalence.nix index c024db0924..188cbc686d 100644 --- a/third_party/lisp/cl-prevalence.nix +++ b/third_party/lisp/cl-prevalence.nix @@ -1,17 +1,13 @@ # cl-prevalence is an implementation of object prevalence for CL (i.e. # an in-memory database) -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "40ants"; - repo = "cl-prevalence"; - rev = "da3ed6c4594b1c2fca90c178c1993973c4bf16c9"; - sha256 = "0bq905hv1626dl6b7s0zn4lbdh608g1pxaljl1fda6pwp9hmj95a"; -}; +let src = with pkgs; srcOnly lispPackages.cl-prevalence; in depot.nix.buildLisp.library { name = "cl-prevalence"; deps = with depot.third_party.lisp; [ + bordeaux-threads s-xml s-sysdeps ]; diff --git a/third_party/lisp/cl-smtp.nix b/third_party/lisp/cl-smtp.nix new file mode 100644 index 0000000000..7ab9bea59f --- /dev/null +++ b/third_party/lisp/cl-smtp.nix @@ -0,0 +1,24 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-smtp; +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 index 8b42e2eaec..815d99c2dc 100644 --- a/third_party/lisp/cl-unicode.nix +++ b/third_party/lisp/cl-unicode.nix @@ -29,7 +29,10 @@ let deps = with depot.third_party.lisp; [ cl-unicode-base flexi-streams - (bundled "uiop") + { + ecl = bundled "asdf"; + default = bundled "uiop"; + } ]; srcs = (map (f: src + ("/build/" + f)) [ @@ -37,7 +40,7 @@ let "char-info.lisp" "read.lisp" ]) ++ [ - (runCommand "dump.lisp" {} '' + (runCommand "dump.lisp" { } '' substitute ${src}/build/dump.lisp $out \ --replace ':defaults *this-file*' ":defaults (uiop:getcwd)" '') @@ -52,7 +55,7 @@ let }; - generated = runCommand "cl-unicode-generated" {} '' + generated = runCommand "cl-unicode-generated" { } '' mkdir -p $out/build mkdir -p $out/test cd $out/build @@ -63,7 +66,7 @@ let in depot.nix.buildLisp.library { name = "cl-unicode"; - deps = [cl-unicode-base]; + deps = [ cl-unicode-base ]; srcs = [ "${src}/conditions.lisp" "${generated}/lists.lisp" diff --git a/third_party/lisp/cl-who.nix b/third_party/lisp/cl-who.nix index 50e4e68c03..601b09f118 100644 --- a/third_party/lisp/cl-who.nix +++ b/third_party/lisp/cl-who.nix @@ -1,14 +1,6 @@ { depot, pkgs, ... }: -let - - src = pkgs.fetchFromGitHub { - owner = "edicl"; - repo = "cl-who"; - rev = "0d3826475133271ee8c590937136c1bc41b8cbe0"; - sha256 = "0sc8nji9q1df04lhsiwsjy1a35996bibl31w5hp5sh8q6sa122dy"; - }; - +let src = with pkgs; srcOnly lispPackages.cl-who; in depot.nix.buildLisp.library { name = "cl-who"; diff --git a/third_party/lisp/cl-yacc.nix b/third_party/lisp/cl-yacc.nix index d2ceb81103..b40d5d0601 100644 --- a/third_party/lisp/cl-yacc.nix +++ b/third_party/lisp/cl-yacc.nix @@ -1,12 +1,14 @@ { depot, pkgs, ... }: -let src = pkgs.fetchFromGitHub { +let + src = pkgs.fetchFromGitHub { owner = "jech"; repo = "cl-yacc"; rev = "1334f5469251ffb3f8738a682dc8ee646cb26635"; sha256 = "16946pzf8vvadnyfayvj8rbh4zjzw90h0azz2qk1mxrvhh5wklib"; }; -in depot.nix.buildLisp.library { +in +depot.nix.buildLisp.library { name = "cl-yacc"; srcs = map (f: src + ("/" + f)) [ diff --git a/third_party/lisp/closer-mop.nix b/third_party/lisp/closer-mop.nix index ab7e33e59b..145b9cfd43 100644 --- a/third_party/lisp/closer-mop.nix +++ b/third_party/lisp/closer-mop.nix @@ -1,20 +1,19 @@ # 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, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "pcostanza"; - repo = "closer-mop"; - rev = "e1d1430524086709a7ea8e0eede6849aa29d6276"; - sha256 = "1zda6927379pmrsxpg29jnj6azjpa2pms9h7n1iwhy6q9d3w06rf"; -}; +let src = with pkgs; srcOnly lispPackages.closer-mop; in depot.nix.buildLisp.library { name = "closer-mop"; srcs = [ "${src}/closer-mop-packages.lisp" "${src}/closer-mop-shared.lisp" - "${src}/closer-sbcl.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 0000000000..7f7f79f855 --- /dev/null +++ b/third_party/lisp/closure-common.nix @@ -0,0 +1,36 @@ +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.closure-common; + 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 0000000000..1886ea2ec9 --- /dev/null +++ b/third_party/lisp/closure-html/default.nix @@ -0,0 +1,65 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + name = "closure-html-source"; + src = pkgs.lispPackages.closure-html.src; + + 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 0000000000..a9ffd8085e --- /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 0000000000..ce7fb33abf --- /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 deleted file mode 100644 index 18593421e8..0000000000 --- a/third_party/lisp/data-sift.nix +++ /dev/null @@ -1,27 +0,0 @@ -{ 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 index 2573e46f53..c31ddb3c5b 100644 --- a/third_party/lisp/defclass-std.nix +++ b/third_party/lisp/defclass-std.nix @@ -1,11 +1,8 @@ +# 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 = "0300f171c1308e5ff3efd66b4f4e766f2bcde259"; - sha256 = "0ggzh80ajx4k6w5c3xprnd7m27q5hx9xx9lxs4jv0pbrlg18ijcw"; - }; +let src = with pkgs; srcOnly lispPackages.defclass-std; in depot.nix.buildLisp.library { name = "defclass-std"; deps = with depot.third_party.lisp; [ diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix index 8b8b9f1c90..607f438d7e 100644 --- a/third_party/lisp/drakma.nix +++ b/third_party/lisp/drakma.nix @@ -1,15 +1,8 @@ # Drakma is an HTTP client for Common Lisp. -{ depot, ... }: +{ depot, pkgs, ... }: -with depot.nix; - -let src = depot.third_party.fetchFromGitHub { - owner = "edicl"; - repo = "drakma"; - rev = "87feb02bef00b11a753d5fb21a5fec526b0d0bbb"; - sha256 = "01b80am2vrw94xmdj7f21qm7p5ys08mmpzv4nc4icql81hqr1w2m"; -}; -in buildLisp.library { +let src = with pkgs; srcOnly lispPackages.drakma; +in depot.nix.buildLisp.library { name = "drakma"; deps = with depot.third_party.lisp; [ chipz @@ -20,7 +13,7 @@ in buildLisp.library { flexi-streams puri usocket - (buildLisp.bundled "asdf") + (depot.nix.buildLisp.bundled "asdf") ]; srcs = map (f: src + ("/" + f)) [ @@ -34,4 +27,8 @@ in buildLisp.library { "encoding.lisp" "request.lisp" ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; } diff --git a/third_party/lisp/easy-routes.nix b/third_party/lisp/easy-routes.nix index 63eb8b5e38..5caf8261fa 100644 --- a/third_party/lisp/easy-routes.nix +++ b/third_party/lisp/easy-routes.nix @@ -9,7 +9,8 @@ let sha256 = "06lnipwc6mmg0v5gybcnr7wn5xmn5xfd1gs19vbima777245bfka"; }; -in depot.nix.buildLisp.library { +in +depot.nix.buildLisp.library { name = "easy-routes"; deps = with depot.third_party.lisp; [ hunchentoot @@ -23,4 +24,7 @@ in depot.nix.buildLisp.library { "routes-map-printer.lisp" ]; + brokenOn = [ + "ecl" # dynamic cffi + ]; } diff --git a/third_party/lisp/fiveam.nix b/third_party/lisp/fiveam.nix new file mode 100644 index 0000000000..500e980a81 --- /dev/null +++ b/third_party/lisp/fiveam.nix @@ -0,0 +1,29 @@ +# FiveAM is a Common Lisp testing framework. +# +# Imported from https://github.com/sionescu/fiveam.git + +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.fiveam; +in depot.nix.buildLisp.library { + name = "fiveam"; + + deps = with depot.third_party.lisp; [ + alexandria + asdf-flv + trivial-backtrace + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "utils.lisp" + "check.lisp" + "fixture.lisp" + "classes.lisp" + "random.lisp" + "test.lisp" + "explain.lisp" + "suite.lisp" + "run.lisp" + ]; +} diff --git a/third_party/lisp/fiveam/.boring b/third_party/lisp/fiveam/.boring deleted file mode 100644 index 662944f765..0000000000 --- a/third_party/lisp/fiveam/.boring +++ /dev/null @@ -1,14 +0,0 @@ -# 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 deleted file mode 100644 index 6f6559189f..0000000000 --- a/third_party/lisp/fiveam/.travis.yml +++ /dev/null @@ -1,47 +0,0 @@ -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 deleted file mode 100644 index 91adf85a5a..0000000000 --- a/third_party/lisp/fiveam/COPYING +++ /dev/null @@ -1,30 +0,0 @@ -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 deleted file mode 100644 index 32a205fa5f..0000000000 --- a/third_party/lisp/fiveam/README +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index 4236b93bc9..0000000000 --- a/third_party/lisp/fiveam/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -# 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 deleted file mode 100644 index 8144c94f02..0000000000 --- a/third_party/lisp/fiveam/docs/make-qbook.lisp +++ /dev/null @@ -1,13 +0,0 @@ -(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 deleted file mode 100644 index 7607e33372..0000000000 --- a/third_party/lisp/fiveam/fiveam.asd +++ /dev/null @@ -1,36 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index b3808c5cf0..0000000000 --- a/third_party/lisp/fiveam/src/check.lisp +++ /dev/null @@ -1,311 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index fc4dc782e8..0000000000 --- a/third_party/lisp/fiveam/src/classes.lisp +++ /dev/null @@ -1,128 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 015cdf4552..0000000000 --- a/third_party/lisp/fiveam/src/explain.lisp +++ /dev/null @@ -1,133 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 26e993304f..0000000000 --- a/third_party/lisp/fiveam/src/fixture.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;; -*- 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 deleted file mode 100644 index 3279a9a4f7..0000000000 --- a/third_party/lisp/fiveam/src/package.lisp +++ /dev/null @@ -1,139 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 49e14bc8a8..0000000000 --- a/third_party/lisp/fiveam/src/random.lisp +++ /dev/null @@ -1,265 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 89c5223515..0000000000 --- a/third_party/lisp/fiveam/src/run.lisp +++ /dev/null @@ -1,385 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 4a1e6010dc..0000000000 --- a/third_party/lisp/fiveam/src/style.css +++ /dev/null @@ -1,64 +0,0 @@ -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 deleted file mode 100644 index 8497a9d12d..0000000000 --- a/third_party/lisp/fiveam/src/suite.lisp +++ /dev/null @@ -1,140 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 4a6f2fee9a..0000000000 --- a/third_party/lisp/fiveam/src/test.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 49d552fa00..0000000000 --- a/third_party/lisp/fiveam/src/utils.lisp +++ /dev/null @@ -1,226 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index c949511a28..0000000000 --- a/third_party/lisp/fiveam/t/example.lisp +++ /dev/null @@ -1,126 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index ed1c565e7d..0000000000 --- a/third_party/lisp/fiveam/t/tests.lisp +++ /dev/null @@ -1,280 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index e0e0284e67..0000000000 --- a/third_party/lisp/fiveam/version.sexp +++ /dev/null @@ -1,2 +0,0 @@ -;; -*- lisp -*- -"1.4.1" diff --git a/third_party/lisp/flexi-streams.nix b/third_party/lisp/flexi-streams.nix index 8cdf062f1c..a6a06d4ad0 100644 --- a/third_party/lisp/flexi-streams.nix +++ b/third_party/lisp/flexi-streams.nix @@ -1,10 +1,7 @@ # Flexible bivalent streams for Common Lisp -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/edicl/flexi-streams.git"; - rev = "0fd872ae32022e834ef861a67d86879cf33a6b64"; -}; +let src = with pkgs; srcOnly lispPackages.flexi-streams; in depot.nix.buildLisp.library { name = "flexi-streams"; deps = [ depot.third_party.lisp.trivial-gray-streams ]; @@ -14,7 +11,9 @@ in depot.nix.buildLisp.library { "mapping.lisp" "ascii.lisp" "koi8-r.lisp" + "mac.lisp" "iso-8859.lisp" + "enc-cn-tbl.lisp" "code-pages.lisp" "specials.lisp" "util.lisp" @@ -29,6 +28,6 @@ in depot.nix.buildLisp.library { "input.lisp" "io.lisp" "strings.lisp" - ]; + ]; } diff --git a/third_party/lisp/global-vars.nix b/third_party/lisp/global-vars.nix index 2b4078f588..a3d27a09b6 100644 --- a/third_party/lisp/global-vars.nix +++ b/third_party/lisp/global-vars.nix @@ -1,14 +1,7 @@ { depot, pkgs, ... }: -let - src = pkgs.fetchFromGitHub { - owner = "lmj"; - repo = "global-vars"; - rev = "c749f32c9b606a1457daa47d59630708ac0c266e"; - sha256 = "06m3xc8l3pgsapl8fvsi9wf6y46zs75cp9zn7zh6dc65v4s5wz3d"; - }; - +let src = with pkgs; srcOnly lispPackages.global-vars; in depot.nix.buildLisp.library { name = "global-vars"; - srcs = [ "${src}/global-vars.lisp" ] ; + srcs = [ "${src}/global-vars.lisp" ]; } diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix index 9977405c65..e2480cd349 100644 --- a/third_party/lisp/hunchentoot.nix +++ b/third_party/lisp/hunchentoot.nix @@ -1,13 +1,9 @@ # Hunchentoot is a web framework for Common Lisp. -{ depot, ...}: +{ depot, pkgs, ... }: let - src = depot.third_party.fetchFromGitHub { - owner = "edicl"; - repo = "hunchentoot"; - rev = "585b45b6b873f2da421fdf456b61860ab5868207"; - sha256 = "13nazwix067mdclq9vgjhsi2vpr57a8dz51dd5d3h99ccsq4mik5"; - }; + src = with pkgs; srcOnly lispPackages.hunchentoot; + url-rewrite = depot.nix.buildLisp.library { name = "url-rewrite"; @@ -19,7 +15,8 @@ let "url-rewrite.lisp" ]; }; -in depot.nix.buildLisp.library { +in +depot.nix.buildLisp.library { name = "hunchentoot"; deps = with depot.third_party.lisp; [ @@ -58,4 +55,8 @@ in depot.nix.buildLisp.library { "acceptor.lisp" "easy-handlers.lisp" ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; } diff --git a/third_party/lisp/ironclad.nix b/third_party/lisp/ironclad.nix index 9bdf87114a..324c5da265 100644 --- a/third_party/lisp/ironclad.nix +++ b/third_party/lisp/ironclad.nix @@ -1,71 +1,74 @@ -{ depot, pkgs, ...}: +{ depot, pkgs, ... }: let inherit (pkgs) runCommand; inherit (depot.nix.buildLisp) bundled; - src = pkgs.fetchFromGitHub { - owner = "sharplispers"; - repo = "ironclad"; - rev = "c3aa33080621abc10fdb0f34acc4655cc4e982a6"; - sha256 = "0k4bib9mbrzalbl9ivkw4a7g4c7bbad1l5jw4pzkifqszy2swkr5"; - }; - -in depot.nix.buildLisp.library { + src = with pkgs; srcOnly lispPackages.ironclad; + getSrc = f: "${src}/src/${f}"; + +in +depot.nix.buildLisp.library { name = "ironclad"; deps = with depot.third_party.lisp; [ (bundled "asdf") - (bundled "sb-rotate-byte") + { sbcl = bundled "sb-rotate-byte"; } + { sbcl = bundled "sb-posix"; } alexandria bordeaux-threads nibbles ]; - srcs = [ - "${src}/ironclad.asd" - # TODO(grfn): Figure out how to get this compiling with the assembly - # optimization eventually - see https://cl.tvl.fyi/c/depot/+/1333 - (runCommand "package.lisp" {} '' - substitute ${src}/src/package.lisp $out \ - --replace \#-ecl-bytecmp "" \ - --replace '(pushnew :ironclad-assembly *features*)' "" - '') - ] ++ (map (f: src + ("/src/" + f)) [ + srcs = map getSrc [ + # { + # # 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"; + # } + "package.lisp" + "conditions.lisp" + "generic.lisp" "macro-utils.lisp" + "util.lisp" + ] ++ [ + { sbcl = getSrc "opt/sbcl/fndb.lisp"; } + { sbcl = getSrc "opt/sbcl/cpu-features.lisp"; } + { sbcl = getSrc "opt/sbcl/x86oid-vm.lisp"; } - "opt/sbcl/fndb.lisp" - "opt/sbcl/cpu-features.lisp" - "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/padding.lisp" + "ciphers/make-cipher.lisp" "ciphers/modes.lisp" - "ciphers/salsa20.lisp" - "ciphers/xchacha.lisp" - "ciphers/xsalsa20.lisp" + + # subsystem def ironclad/ciphers "ciphers/aes.lisp" "ciphers/arcfour.lisp" - "ciphers/arcfour.lisp" "ciphers/aria.lisp" "ciphers/blowfish.lisp" "ciphers/camellia.lisp" "ciphers/cast5.lisp" + "ciphers/chacha.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/salsa20.lisp" + "ciphers/keystream.lisp" "ciphers/seed.lisp" "ciphers/serpent.lisp" "ciphers/sm4.lisp" @@ -74,10 +77,13 @@ in depot.nix.buildLisp.library { "ciphers/tea.lisp" "ciphers/threefish.lisp" "ciphers/twofish.lisp" + "ciphers/xchacha.lisp" "ciphers/xor.lisp" + "ciphers/xsalsa20.lisp" "ciphers/xtea.lisp" "digests/digest.lisp" + # subsystem def ironclad/digests "digests/adler32.lisp" "digests/blake2.lisp" "digests/blake2s.lisp" @@ -103,14 +109,8 @@ in depot.nix.buildLisp.library { "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" + # subsystem def ironclad/macs "macs/blake2-mac.lisp" "macs/blake2s-mac.lisp" "macs/cmac.lisp" @@ -120,26 +120,44 @@ in depot.nix.buildLisp.library { "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" + "prng/prng.lisp" + "prng/os-prng.lisp" + "prng/generator.lisp" + "prng/fortuna.lisp" + + "math.lisp" + + "octet-stream.lisp" "aead/aead.lisp" + # subsystem def ironclad/aead "aead/eax.lisp" "aead/etm.lisp" "aead/gcm.lisp" + "kdf/kdf.lisp" + # subsystem def ironclad/kdfs + "kdf/argon2.lisp" + "kdf/bcrypt.lisp" + "kdf/hmac.lisp" + "kdf/pkcs5.lisp" + "kdf/password-hash.lisp" + "kdf/scrypt.lisp" + "public-key/public-key.lisp" + "public-key/pkcs1.lisp" + "public-key/elliptic-curve.lisp" + # subsystem def ironclad/public-keys + "public-key/dsa.lisp" + "public-key/rsa.lisp" + "public-key/elgamal.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" - ]); + "public-key/secp256k1.lisp" + "public-key/secp256r1.lisp" + "public-key/secp384r1.lisp" + "public-key/secp521r1.lisp" + ]; } diff --git a/third_party/lisp/iterate.nix b/third_party/lisp/iterate.nix index 2e6873885f..b7d60265ac 100644 --- a/third_party/lisp/iterate.nix +++ b/third_party/lisp/iterate.nix @@ -1,11 +1,8 @@ # iterate is an iteration construct for Common Lisp, similar to the # LOOP macro. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://gitlab.common-lisp.net/iterate/iterate.git"; - rev = "a1c47b2b74f6c96149d717be90c07a1b273ced69"; -}; +let src = with pkgs; srcOnly lispPackages.iterate; in depot.nix.buildLisp.library { name = "iterate"; srcs = [ diff --git a/third_party/lisp/lass.nix b/third_party/lisp/lass.nix index 457e25c7e5..00f66c1fe3 100644 --- a/third_party/lisp/lass.nix +++ b/third_party/lisp/lass.nix @@ -8,7 +8,8 @@ let sha256 = "11mxzyx34ynsfsrs8pgrarqi9s442vkpmh7kdpzvarhj7i97g8yx"; }; -in depot.nix.buildLisp.library { +in +depot.nix.buildLisp.library { name = "lass"; deps = with depot.third_party.lisp; [ diff --git a/third_party/lisp/let-plus.nix b/third_party/lisp/let-plus.nix new file mode 100644 index 0000000000..bd7f31dfa0 --- /dev/null +++ b/third_party/lisp/let-plus.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.let-plus; +in depot.nix.buildLisp.library { + name = "let-plus"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.anaphora + ]; + srcs = [ + "${src}/package.lisp" + "${src}/let-plus.lisp" + "${src}/extensions.lisp" + ]; +} diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix index f2dab565c2..296112cc9e 100644 --- a/third_party/lisp/lisp-binary.nix +++ b/third_party/lisp/lisp-binary.nix @@ -1,21 +1,19 @@ # A library to easily read and write complex binary formats. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "j3pic"; - repo = "lisp-binary"; - rev = "1aefc8618b7734f68697ddf59bc93cb8522aa0bf"; - sha256 = "1hflzn3mjp32jz9fxx9wayp3c3x58s77cgjfbs06nrynqkv0c6df"; -}; -in depot.nix.buildLisp.library { +let + src = pkgs.srcOnly pkgs.lispPackages.lisp-binary; +in +depot.nix.buildLisp.library { name = "lisp-binary"; deps = with depot.third_party.lisp; [ + alexandria cffi - quasiquote_2 - moptilities - flexi-streams closer-mop + flexi-streams + moptilities + quasiquote_2 ]; srcs = map (f: src + ("/" + f)) [ @@ -26,5 +24,10 @@ in depot.nix.buildLisp.library { "reverse-stream.lisp" "binary-1.lisp" "binary-2.lisp" + "types.lisp" + ]; + + brokenOn = [ + "ecl" # TODO(sterni): disable conditionally cffi for ECL ]; } diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix index 52e7c257e4..1358408d38 100644 --- a/third_party/lisp/local-time.nix +++ b/third_party/lisp/local-time.nix @@ -1,15 +1,19 @@ # Library for manipulating dates & times -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "dlowe-net"; - repo = "local-time"; - rev = "dc54f61415c76ee755a6f69d4154a3a282f2789f"; - sha256 = "1l9v07ghx7g9p2gp003fki4j8bsa1w2gbm40qc41i94mdzikc0ry"; -}; -in depot.nix.buildLisp.library { +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.local-time; +in +buildLisp.library { name = "local-time"; - deps = [ depot.third_party.lisp.cl-fad ]; + deps = [ + depot.third_party.lisp.cl-fad + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + ]; srcs = [ "${src}/src/package.lisp" diff --git a/third_party/lisp/marshal.nix b/third_party/lisp/marshal.nix index 711e6e082d..73a1664a01 100644 --- a/third_party/lisp/marshal.nix +++ b/third_party/lisp/marshal.nix @@ -1,13 +1,6 @@ { depot, pkgs, ... }: -let - src = pkgs.fetchFromGitHub { - owner = "wlbr"; - repo = "cl-marshal"; - rev = "eff1b15f2b0af2f26f71ad6a4dd5c4beab9299ec"; - sha256 = "08qs6fhk38xpkkjkpcj92mxx0lgy4ygrbbzrmnivdx281syr0gwh"; - }; - +let src = with pkgs; srcOnly lispPackages.marshal; in depot.nix.buildLisp.library { name = "marshal"; srcs = map (f: src + ("/" + f)) [ diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix index 3f2ed371de..8c3e255f16 100644 --- a/third_party/lisp/md5.nix +++ b/third_party/lisp/md5.nix @@ -1,16 +1,16 @@ # MD5 hash implementation -{ depot, ... }: +{ depot, pkgs, ... }: with depot.nix; -let src = depot.third_party.fetchFromGitHub { - owner = "pmai"; - repo = "md5"; - rev = "b1412600f60d526ee34a7ba1596ec483da7894ab"; - sha256 = "0lzip6b6xg7gd70xl1xmqp24fvxqj6ywjnz9lmx7988zpj20nhl2"; -}; +let src = with pkgs; srcOnly lispPackages.md5; in buildLisp.library { name = "md5"; - deps = [ (buildLisp.bundled "sb-rotate-byte") ]; + deps = [ + { + sbcl = buildLisp.bundled "sb-rotate-byte"; + default = depot.third_party.lisp.flexi-streams; + } + ]; srcs = [ (src + "/md5.lisp") ]; } diff --git a/third_party/lisp/metabang-bind.nix b/third_party/lisp/metabang-bind.nix new file mode 100644 index 0000000000..fc046d0895 --- /dev/null +++ b/third_party/lisp/metabang-bind.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +let + getSrcs = builtins.map (p: "${pkgs.srcOnly pkgs.lispPackages.metabang-bind}/${p}"); +in + +depot.nix.buildLisp.library { + name = "metabang-bind"; + + srcs = getSrcs [ + "dev/packages.lisp" + "dev/macros.lisp" + "dev/bind.lisp" + "dev/binding-forms.lisp" + ]; +} diff --git a/third_party/lisp/mime4cl/.skip-subtree b/third_party/lisp/mime4cl/.skip-subtree new file mode 100644 index 0000000000..5051f60d6b --- /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 0000000000..2e95807063 --- /dev/null +++ b/third_party/lisp/mime4cl/OWNERS @@ -0,0 +1 @@ +sterni diff --git a/third_party/lisp/mime4cl/README.md b/third_party/lisp/mime4cl/README.md new file mode 100644 index 0000000000..2704d481ed --- /dev/null +++ b/third_party/lisp/mime4cl/README.md @@ -0,0 +1,27 @@ +# mime4cl + +`MIME4CL` is a Common Lisp library for dealing with MIME messages. It was +originally been written by Walter C. Pelissero and vendored into depot +([mime4cl-20150207T211851.tbz](http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz) +to be exact) as upstream has become inactive. Its [original +website](http://wcp.sdf-eu.org/software/#mime4cl) can still be accessed. + +The depot version has since diverged from upstream. Main aims were to improve +performance and reduce code size by relying on third party libraries like +flexi-streams. It is planned to improve encoding handling in the long term. +Currently, the library is being worked on intermittently and not very well +tested—**it may not work as expected**. + +## Differences from the original version + +* `//nix/buildLisp` is used as the build system. ASDF is currently untested and + may be broken. + +* The dependency on [sclf](http://wcp.sdf-eu.org/software/#sclf) has been + eliminated by inlining the relevant parts. + +* `MY-STRING-INPUT-STREAM`, `DELIMITED-INPUT-STREAM`, + `CHARACTER-INPUT-ADAPTER-STREAM`, `BINARY-INPUT-ADAPTER-STREAM` etc. have been + replaced by (thin wrappers around) flexi-streams. In addition to improved + handling of encodings, this allows using `READ-SEQUENCE` via the gray stream + interface. diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp new file mode 100644 index 0000000000..42688a595b --- /dev/null +++ b/third_party/lisp/mime4cl/address.lisp @@ -0,0 +1,300 @@ +;;; address.lisp --- e-mail address parser + +;;; Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022-2023 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 + +;;; 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) + (let ((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))))) + (let ((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) + (let ((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." + (let ((grammar (force define-grammar))) + (with-input-from-string (stream string) + (let* ((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." + (let ((grammar (force define-grammar))) + (with-input-from-string (stream string) + (let ((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 0000000000..af015a257b --- /dev/null +++ b/third_party/lisp/mime4cl/default.nix @@ -0,0 +1,51 @@ +# 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.flexi-streams + depot.third_party.lisp.npg + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.qbase64 + { sbcl = depot.nix.buildLisp.bundled "sb-posix"; } + ]; + + srcs = [ + ./ex-sclf.lisp + ./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) + + ;; override auto discovery which doesn't work in the nix store + (defvar *samples-directory* (pathname "${./test/samples}/")) + '') + ./test/temp-file.lisp + ./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 0000000000..2e282c2378 --- /dev/null +++ b/third_party/lisp/mime4cl/endec.lisp @@ -0,0 +1,663 @@ +;;; endec.lisp --- encoder/decoder functions + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2023 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) + +(defun redirect-stream (in out &key (buffer-size 4096)) + "Consume input stream IN and write all its content to output stream OUT. +The streams' element types need to match." + (let ((buf (make-array buffer-size :element-type (stream-element-type in)))) + (loop for pos = (read-sequence buf in) + while (> pos 0) + do (write-sequence buf out :end pos)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Thank you SBCL for rendering constants totally useless! +(defparameter +base64-encode-table+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") + +(declaim (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 (let ((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 () + (let ((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 #\=) + (let ((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 + (let ((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) + `(let ((,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." + (let ((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." + (let ((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))) + +(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." + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (redirect-stream (make-instance 'qbase64:decode-stream + :underlying-stream in) + out)) + +(defun decode-base64-stream-to-sequence (stream &key parser-errors) + "Read Base64 characters from STREAM and return result of decoding them as a +binary sequence." + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (let* ((buffered-size 4096) + (dstream (make-instance 'qbase64:decode-stream + :underlying-stream stream)) + (output-seq (make-array buffered-size + :element-type '(unsigned-byte 8) + :adjustable t))) + (loop for cap = (array-dimension output-seq 0) + for pos = (read-sequence output-seq dstream :start (or pos 0)) + if (>= pos cap) + do (adjust-array output-seq (+ cap buffered-size)) + else + do (progn + (adjust-array output-seq pos) + (return output-seq))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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-string (string encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-string string + :parser-errors parser-errors-p)) + (:base64 + ;; parser-errors-p is unused in base64 + (qbase64:decode-string string)) + (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-part (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" (qbase64:decode-string (subseq string start 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-part 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)))) + +(defun decode-RFC2047 (text) + "Decode TEXT into a fully decoded string. Whenever a non ASCII part is + encountered, try to decode it using flexi-streams, otherwise signal an error." + (flet ((decode-part (part) + (etypecase part + (cons (flexi-streams:octets-to-string + (car part) + :external-format (flexi-streams:make-external-format + (intern (string-upcase (cdr part)) 'keyword)))) + (string part)))) + (apply #'concatenate + (cons 'string + (mapcar #'decode-part (mime:parse-RFC2047-text text)))))) diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp new file mode 100644 index 0000000000..1719732fb3 --- /dev/null +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -0,0 +1,329 @@ +;;; ex-sclf.lisp --- subset of sclf used by mime4cl + +;;; Copyright (C) 2005-2010 by Walter C. Pelissero +;;; Copyright (C) 2022-2023 The TVL Authors + +;;; Author: sternenseemann <sternenseemann@systemli.org> +;;; Project: mime4cl +;;; +;;; mime4cl uses sclf for miscellaneous utility functions. sclf's portability +;;; is quite limited. Since mime4cl is the only thing in TVL's depot depending +;;; on sclf, it made more sense to strip down sclf to the extent mime4cl needed +;;; in order to lessen the burden of porting it to other CL implementations +;;; later. +;;; +;;; Eventually it probably makes sense to drop the utilities we don't like and +;;; merge the ones we do like into depot's own utility package, klatre. + +#+cmu (ext:file-comment "$Module: ex-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 + +(defpackage :mime4cl-ex-sclf + (:use :common-lisp) + (:import-from :sb-posix :stat :stat-size) + + (:export + #:aif + #:awhen + #:aand + #:it + + #:gcase + + #:with-gensyms + + #:split-at + #:split-string-at-char + #:+whitespace+ + #:whitespace-p + #:string-concat + #:s+ + #:string-starts-with + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + + #:queue + #:make-queue + #:queue-append + #:queue-pop + #:queue-empty-p + + #:save-file-excursion + #:read-file + + #:file-size + + #:promise + #:make-promise + #:lazy + #:force + #:forced-p + #:deflazy + + #:f++ + + #:week-day->string + #:month->string)) + +(in-package :mime4cl-ex-sclf) + +;; MACRO UTILS + +(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)) + +;; CONTROL FLOW + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(let ((it ,test)) + (when it + ,@then))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(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) + `(let ((,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))))) + +;; SEQUENCES + +(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 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." + (let ((len (length sequence))) + (labels ((split-from (start) + (unless (>= start len) + (let ((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)))) + +;; STRINGS + +(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(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 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) + (let ((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 s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(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)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (let ((prefix-length (length prefix))) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +;; QUEUE + +(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))) + +;; STREAMS + +(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))) + `(let ((,position (file-position ,stream))) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(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 + (let ((seq (make-array (file-length in) :element-type element-type))) + (read-sequence seq in) + seq) + default))) + +;; FILES + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +;; 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) + #+sbcl (stat-size (unix-stat pathname)) + #-sbcl (error "nyi")) + +;; LAZY + +(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)))) + +;; FIXNUMS + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +;; TIME + +(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)) + +(defvar +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))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp new file mode 100644 index 0000000000..3cdac4b26b --- /dev/null +++ b/third_party/lisp/mime4cl/mime.lisp @@ -0,0 +1,1049 @@ +;;; mime4cl.lisp --- MIME primitives for Common Lisp + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021-2023 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) + (make-input-adapter (mime-body mime-part))) + +(defun mime-body-length (mime-part) + (let ((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) &body forms) + `(with-open-stream (,stream (mime-body-stream ,part)) + ,@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." + ;; TODO(sterni): when-let + (let ((equal-position (position #\= string))) + (when equal-position + (let ((key (subseq string 0 equal-position))) + (if (= equal-position (1- (length string))) + (cons key "") + (let ((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)) + (let ((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\"))." + (let ((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." + (let ((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))))) + +(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) + (let ((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 = (let ((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.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun mime-message-header-values (name message &key decode) + "Return all values of the header with NAME in MESSAGE, optionally decoding + it according to RFC2047 if :DECODE is T." + (loop ;; A header may occur multiple times + for header in (mime-message-headers message) + ;; MIME Headers should be case insensitive + ;; https://stackoverflow.com/a/6143644 + when (string-equal (car header) name) + collect (if decode + (decode-RFC2047 (cdr header)) + (cdr header)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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 flexi-stream)) + (let ((base (flexi-stream-root-stream stream))) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (etypecase base + (vector-stream + (flexi-streams::vector-stream-vector base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (flexi-stream-position stream) + :end (flexi-stream-bound 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 vector-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (flexi-streams::vector-stream-vector stream) + :encoding (mime-encoding part) + :start (flexi-streams::vector-stream-index 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) + (let ((offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary)))) + (setf (mime-parts part) + (mapcar #'(lambda (p) + (destructuring-bind (start . end) p + (let ((*default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii"))))) + (in (make-positioned-flexi-input-stream stream + :position start + :bound end + :ignore-close t))) + (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))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar +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) + (let ((elt (assoc name headers :test #'string-equal))) + (values (cdr elt) (car elt)))) + +(defun (setf header) (value name headers) + (let ((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." + (let ((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." + (let ((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)) + (mime-message (flexi-streams:string-to-octets msg))) + +(defmethod mime-message ((msg vector)) + (with-input-from-sequence (in msg) + (mime-message in))) + +(defmethod mime-message ((msg pathname)) + (with-open-file (in msg :element-type '(unsigned-byte 8)) + (mime-message in))) + +(defmethod mime-message ((msg flexi-stream)) + (read-mime-message msg)) + +(defmethod mime-message ((msg stream)) + (read-mime-message (make-flexi-stream msg))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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)) + (let ((body (mime-body part))) + (make-instance (case (mime-encoding part) + (:base64 + 'base64-encoder-input-stream) + (:quoted-printable + 'quoted-printable-encoder-input-stream) + (otherwise + '8bit-encoder-input-stream)) + :underlying-stream + (make-input-adapter 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)) + (let ((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 + (let ((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)) + (let ((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 + (let ((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)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric 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 0000000000..f3b429eafb --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl-tests.asd @@ -0,0 +1,55 @@ +;;; mime4cl-tests.asd --- system description for the regression tests + +;;; Copyright (C) 2006, 2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 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 + +#-(or sbcl) +(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 0000000000..6528f115d4 --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl.asd @@ -0,0 +1,49 @@ +;;; mime4cl.asd --- system definition + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; 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) + +(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 :trivial-gray-streams) + :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 0000000000..94b9e6b390 --- /dev/null +++ b/third_party/lisp/mime4cl/package.lisp @@ -0,0 +1,103 @@ +;;; package.lisp --- package declaration + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 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 :cl-user) + +(defpackage :mime4cl + (:nicknames :mime) + (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams :flexi-streams) + (: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-message-header-values + #: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 + #:encode-base64-stream + #:encode-base64-sequence + #:parse-RFC2047-text + #:decode-RFC2047 + #: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 + #: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 + ;; streams.lisp + #:redirect-stream + )) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp new file mode 100644 index 0000000000..71a32d84e4 --- /dev/null +++ b/third_party/lisp/mime4cl/streams.lisp @@ -0,0 +1,274 @@ +;;; streams.lisp --- En/De-coding Streams + +;;; Copyright (C) 2012 by Walter C. Pelissero +;;; Copyright (C) 2021-2023 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) + +(defun flexi-stream-root-stream (stream) + "Return the non FLEXI-STREAM stream a given chain of FLEXI-STREAMs is based on." + (if (typep stream 'flexi-stream) + (flexi-stream-root-stream (flexi-stream-stream stream)) + stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass coder-stream-mixin () + ((real-stream :type stream + :initarg :underlying-stream + :reader real-stream) + (dont-close :initform nil + :initarg :dont-close))) + +(defmethod stream-file-position ((stream coder-stream-mixin)) + (file-position (slot-value stream 'real-stream))) + +(defmethod (setf stream-file-position) (newval (stream coder-stream-mixin)) + (file-position (slot-value stream 'real-stream) newval)) + +(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin) + ()) +(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin) + ()) + +;; TODO(sterni): temporary, ugly measure to make flexi-streams happy +(defmethod stream-element-type ((stream coder-input-stream-mixin)) + (declare (ignore stream)) + '(unsigned-byte 8)) + +(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-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 :UNDERLYING-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 (let ((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))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-custom-flexi-stream (class stream other-args) + (apply #'make-instance + class + :stream stream + (mapcar (lambda (x) + ;; make-flexi-stream has a discrepancy between :initarg of + ;; make-instance and its &key which we mirror here. + (if (eq x :external-format) :flexi-stream-external-format x)) + other-args))) + +(defclass adapter-flexi-input-stream (flexi-input-stream) + ((ignore-close + :initform nil + :initarg :ignore-close + :documentation + "If T, calling CLOSE on the stream does nothing. +If NIL, the underlying stream is closed.")) + (:documentation "FLEXI-STREAM that does not close the underlying stream on +CLOSE if :IGNORE-CLOSE is T.")) + +(defmethod close ((stream adapter-flexi-input-stream) &key abort) + (declare (ignore abort)) + (with-slots (ignore-close) stream + (unless ignore-close + (call-next-method)))) + +(defun make-input-adapter (source) + (etypecase source + ;; If it's already a stream, we need to make sure it's not closed by the adapter + (stream + (assert (input-stream-p source)) + (if (and (typep source 'adapter-flexi-input-stream) + (slot-value source 'ignore-close)) + source ; already ignores CLOSE + (make-adapter-flexi-input-stream source :ignore-close t))) + ;; TODO(sterni): is this necessary? (maybe with (not *lazy-mime-decode*)?) + (string + (make-input-adapter (string-to-octets source))) + ((vector (unsigned-byte 8)) + (make-in-memory-input-stream source)) + (pathname + (make-flexi-stream (open source :element-type '(unsigned-byte 8)))) + (file-portion + (open-decoded-file-portion source)))) + +(defun make-adapter-flexi-input-stream (stream &rest args) + "Create a ADAPTER-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. If T, the underlying stream is not +closed." + (make-custom-flexi-stream 'adapter-flexi-input-stream stream args)) + +(defclass positioned-flexi-input-stream (adapter-flexi-input-stream) + () + (:documentation + "FLEXI-INPUT-STREAM that automatically advances the underlying :STREAM to +the location given by :POSITION. This uses FILE-POSITION internally, so it'll +only works if the underlying stream position is tracked in bytes. Note that +the underlying stream is still advanced, so having multiple instances of +POSITIONED-FLEXI-INPUT-STREAM based with the same underlying stream won't work +reliably. +Also supports :IGNORE-CLOSE of ADAPTER-FLEXI-INPUT-STREAM.")) + +(defmethod initialize-instance ((stream positioned-flexi-input-stream) + &key &allow-other-keys) + (call-next-method) + ;; The :POSITION initarg is only informational for flexi-streams: It assumes + ;; it is were the stream it got is already at and continuously updates it + ;; for querying (via FLEXI-STREAM-POSITION) and bound checking. + ;; Since we have streams that are not positioned correctly, we need to do this + ;; here using FILE-POSITION. Note that assumes the underlying implementation + ;; uses bytes for FILE-POSITION which is not guaranteed (probably some streams + ;; even in SBCL don't). + (file-position (flexi-stream-stream stream) (flexi-stream-position stream))) + +(defun make-positioned-flexi-input-stream (stream &rest args) + "Create a POSITIONED-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. Causes the FILE-POSITION of STREAM to +be modified to match the :POSITION argument." + (make-custom-flexi-stream 'positioned-flexi-input-stream stream args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO(sterni): test correct behavior with END NIL +(defstruct file-portion + data ; string or a pathname + encoding + start + end) + +(defun open-decoded-file-portion (file-portion) + (with-slots (data encoding start end) + file-portion + (let* ((binary-stream + (etypecase data + (pathname + (open data :element-type '(unsigned-byte 8))) + ((vector (unsigned-byte 8)) + (flexi-streams:make-in-memory-input-stream data)) + (stream + ;; TODO(sterni): assert that bytes/flexi-stream + data))) + (params (ccase encoding + ((:quoted-printable :base64) '(:external-format :us-ascii)) + (:8bit '(:element-type (unsigned-byte 8))) + (:7bit '(:external-format :us-ascii)))) + (portion-stream (apply #'make-positioned-flexi-input-stream + binary-stream + :position start + :bound end + ;; if data is a stream we can't have a + ;; FILE-PORTION without modifying it when + ;; reading etc. The least we can do, though, + ;; is forgo destroying it. + :ignore-close (typep data 'stream) + params)) + (needs-decoder-stream (member encoding '(:quoted-printable + :base64)))) + + (if needs-decoder-stream + (make-instance + (ccase encoding + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'qbase64:decode-stream)) + :underlying-stream portion-stream) + portion-stream)))) diff --git a/third_party/lisp/mime4cl/test/address.lisp b/third_party/lisp/mime4cl/test/address.lisp new file mode 100644 index 0000000000..a3653985c4 --- /dev/null +++ b/third_party/lisp/mime4cl/test/address.lisp @@ -0,0 +1,123 @@ +;;; address.lisp --- tests for the e-mail address parser + +;;; Copyright (C) 2007, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022 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-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 0000000000..6b22b3f6a2 --- /dev/null +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -0,0 +1,184 @@ +;;; endec.lisp --- test suite for the MIME encoder/decoder functions + +;;; Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 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-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 + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + "Some random string.") + +(deftest base64.4 + (map 'string #'code-char + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + "Some random string.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest RFC2047.1 + (parse-RFC2047-text "foo bar") + ("foo bar")) + +;; from RFC2047 section 8 +(deftest RFC2047.2 + (decode-RFC2047 "=?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>") + "Keith Moore <moore@cs.utk.edu>") + +;; from RFC2047 section 8 +(deftest RFC2047.3 + (decode-RFC2047 "=?ISO-8859-1?Q?Olle_J=E4rnefors?=") + "Olle Järnefors") + +;; from RFC2047 section 8 +(deftest RFC2047.4 + (decode-RFC2047 "Nathaniel Borenstein <nsb@thumper.bellcore.com> (=?iso-8859-8?b?7eXs+SDv4SDp7Oj08A==?=)") + "Nathaniel Borenstein <nsb@thumper.bellcore.com> (םולש ןב ילטפנ)") + +;; from RFC2047 section 8 +(deftest RFC2047.5 + (decode-RFC2047 "=?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>") + "Keld Jørn Simonsen <keld@dkuug.dk>") + +(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 ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) + :type "encoded-data"))) + (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: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 0000000000..dbd1dd996d --- /dev/null +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -0,0 +1,41 @@ +;;; mime.lisp --- MIME regression tests + +;;; Copyright (C) 2012 by Walter C. Pelissero +;;; Copyright (C) 2021-2023 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-tests) + +(defvar *samples-directory* + (merge-pathnames (make-pathname :directory '(:relative "samples")) + #.(or *compile-file-pathname* + *load-pathname* + #P""))) + +(loop + for f in (directory (make-pathname :defaults *samples-directory* + :name :wild + :type "msg")) + for i from 1 + do + (add-test (intern (format nil "MIME.~A" i)) + `(let* ((orig (mime-message ,f)) + (dup (mime-message + (with-output-to-string (out) (encode-mime-part orig out))))) + (mime= orig dup)) + t)) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp new file mode 100644 index 0000000000..965680448f --- /dev/null +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -0,0 +1,27 @@ +;;; package.lisp --- package description for the regression tests + +;;; Copyright (C) 2006, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022 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 + +(cl:in-package :common-lisp) + +(defpackage :mime4cl-tests + (:use :common-lisp + :rtest :mime4cl :mime4cl-ex-sclf) + (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp new file mode 100644 index 0000000000..3f3aa5c56c --- /dev/null +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -0,0 +1,258 @@ +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | Copyright 2023 by the TVL Authors | + | | + | 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 #:add-test #: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-test (name form &rest values) + (funcall #'add-entry (append (list '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/samples/sample1.msg b/third_party/lisp/mime4cl/test/samples/sample1.msg new file mode 100644 index 0000000000..662a9fab34 --- /dev/null +++ b/third_party/lisp/mime4cl/test/samples/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/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp new file mode 100644 index 0000000000..554f35844b --- /dev/null +++ b/third_party/lisp/mime4cl/test/temp-file.lisp @@ -0,0 +1,72 @@ +;;; temp-file.lisp --- temporary file creation + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl +;;; +;;; Code taken from SCLF + +#+cmu (ext:file-comment "$Module: temp-file.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 *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." + `(let ((,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)))))) diff --git a/third_party/lisp/moptilities.nix b/third_party/lisp/moptilities.nix index 24a7f2c06d..d38fbcb946 100644 --- a/third_party/lisp/moptilities.nix +++ b/third_party/lisp/moptilities.nix @@ -1,14 +1,13 @@ # Compatibility layer for minor MOP implementation differences -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "gwkkwg"; - repo = "moptilities"; - rev = "a436f16b357c96b82397ec018ea469574c10dd41"; - sha256 = "1q12bqjbj47lx98yim1kfnnhgfhkl80102fkgp9pdqxg0fp6g5fc"; -}; +let src = with pkgs; srcOnly lispPackages.moptilities; 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 index 593bc4b385..b71f439c93 100644 --- a/third_party/lisp/nibbles.nix +++ b/third_party/lisp/nibbles.nix @@ -2,14 +2,9 @@ let inherit (depot.nix.buildLisp) bundled; - src = pkgs.fetchFromGitHub { - owner = "froydnj"; - repo = "nibbles"; - rev = "9de8c755c2ff24117748a3271e8582bb8d4a6b6c"; - sha256 = "11rznn33m950mp4zgnpyjaliy3z3rvibfdr8y4vnk2aq42kqi7dj"; - }; - -in depot.nix.buildLisp.library { + src = with pkgs; srcOnly lispPackages.nibbles; +in +depot.nix.buildLisp.library { name = "nibbles"; deps = with depot.third_party.lisp; [ @@ -20,8 +15,12 @@ in depot.nix.buildLisp.library { "package.lisp" "types.lisp" "macro-utils.lisp" - "types.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 0000000000..82a8fe48bb --- /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 0000000000..5051f60d6b --- /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 0000000000..223ede7de3 --- /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 0000000000..2e95807063 --- /dev/null +++ b/third_party/lisp/npg/OWNERS @@ -0,0 +1 @@ +sterni diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README new file mode 100644 index 0000000000..a1661e744a --- /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 0000000000..af7ec53eaf --- /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 0000000000..a45ac614f7 --- /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 0000000000..9ebd45a169 --- /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 0000000000..1e35186d6c --- /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 0000000000..8b64f5cc0a --- /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 0000000000..783f071fc5 --- /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 0000000000..b405f7b5f1 --- /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 0000000000..c15d26fe39 --- /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 index 4e36e69c7d..e90824108e 100644 --- a/third_party/lisp/parse-float.nix +++ b/third_party/lisp/parse-float.nix @@ -1,13 +1,6 @@ { depot, pkgs, ... }: -let - src = pkgs.fetchFromGitHub { - owner = "soemraws"; - repo = "parse-float"; - rev = "3074765101e41222b6b624a66aaf1e6416379f9c"; - sha256 = "0jd2spawc3v8vzqf8ky4cngl45jm65fhkrdf20mf6dcbn3mzpkmr"; - }; - +let src = with pkgs; srcOnly lispPackages.parse-float; in depot.nix.buildLisp.library { name = "parse-float"; diff --git a/third_party/lisp/parse-number.nix b/third_party/lisp/parse-number.nix index 1ceba2863d..61b0b1fddb 100644 --- a/third_party/lisp/parse-number.nix +++ b/third_party/lisp/parse-number.nix @@ -1,14 +1,6 @@ { depot, pkgs, ... }: -let - - src = pkgs.fetchFromGitHub { - owner = "sharplispers"; - repo = "parse-number"; - rev = "7707b224c4b941c2cbd28459113534242cee3a31"; - sha256 = "0sk06ib1bhqv9y39vwnnw44vmbc4b0kvqm37xxmkxd4dwchq82d7"; - }; - +let src = with pkgs; srcOnly lispPackages.parse-number; in depot.nix.buildLisp.library { name = "parse-number"; srcs = map (f: src + ("/" + f)) [ diff --git a/third_party/lisp/parseq.nix b/third_party/lisp/parseq.nix index fe045d5299..23c67c2d9c 100644 --- a/third_party/lisp/parseq.nix +++ b/third_party/lisp/parseq.nix @@ -1,13 +1,6 @@ { depot, pkgs, ... }: -let - src = pkgs.fetchFromGitHub { - owner = "mrossini-ethz"; - repo = "parseq"; - rev = "5cd95b324b68255d89f27f8065f4c29674558b26"; - sha256 = "1f3vvxgyiv0xn2hzafhh63l3gnvn2vaxr5pi3ld7d340mka2ndg0"; - }; - +let src = with pkgs; srcOnly lispPackages.parseq; in depot.nix.buildLisp.library { name = "parseq"; diff --git a/third_party/lisp/physical-quantities.nix b/third_party/lisp/physical-quantities.nix index 6e124a9132..d594ff1a1c 100644 --- a/third_party/lisp/physical-quantities.nix +++ b/third_party/lisp/physical-quantities.nix @@ -1,12 +1,6 @@ { depot, pkgs, ... }: -let - src = pkgs.fetchFromGitHub { - owner = "mrossini-ethz"; - repo = "physical-quantities"; - rev = "8feb66ef3293fcb9ff4c4bd3ee872bfc385a590e"; - sha256 = "1qznv0hmn2n7g9dxx1iw0qpr0pf2lnbahn0x0b3v50xzcb65kgig"; - }; +let src = with pkgs; srcOnly lispPackages.physical-quantities; in depot.nix.buildLisp.library { name = "physical-quantities"; diff --git a/third_party/lisp/postmodern.nix b/third_party/lisp/postmodern.nix index cc133eeb89..25e0625c20 100644 --- a/third_party/lisp/postmodern.nix +++ b/third_party/lisp/postmodern.nix @@ -2,36 +2,31 @@ let inherit (depot.nix.buildLisp) bundled; - - src = pkgs.fetchFromGitHub { - owner = "marijnh"; - repo = "Postmodern"; - rev = "v1.32"; - sha256 = "0prwmpixcqpzqd67v77cs4zgbs73a10m6hs7q0rpv0z1qm7mqfcb"; - }; + src = with pkgs; srcOnly lispPackages.postmodern; cl-postgres = depot.nix.buildLisp.library { name = "cl-postgres"; - deps = with pkgs.lisp; [ + deps = with depot.third_party.lisp; [ md5 split-sequence ironclad cl-base64 uax-15 usocket - (bundled "sb-bsd-sockets") ]; srcs = map (f: src + ("/cl-postgres/" + f)) [ "package.lisp" "features.lisp" + "config.lisp" + "oid.lisp" "errors.lisp" + "data-types.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" @@ -44,13 +39,14 @@ let s-sql = depot.nix.buildLisp.library { name = "s-sql"; - deps = with pkgs.lisp; [ + deps = with depot.third_party.lisp; [ cl-postgres alexandria ]; srcs = map (f: src + ("/s-sql/" + f)) [ "package.lisp" + "config.lisp" "s-sql.lisp" ]; }; @@ -58,7 +54,7 @@ let postmodern = depot.nix.buildLisp.library { name = "postmodern"; - deps = with pkgs.lisp; [ + deps = with depot.third_party.lisp; [ alexandria cl-postgres s-sql @@ -73,7 +69,9 @@ let "${src}/postmodern.asd" ] ++ (map (f: src + ("/postmodern/" + f)) [ "package.lisp" + "config.lisp" "connect.lisp" + "json-encoder.lisp" "query.lisp" "prepare.lisp" "roles.lisp" @@ -84,8 +82,13 @@ let "table.lisp" "deftable.lisp" ]); + + brokenOn = [ + "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651 + ]; }; -in postmodern // { +in +postmodern // { inherit s-sql cl-postgres; } diff --git a/third_party/lisp/prove.nix b/third_party/lisp/prove.nix new file mode 100644 index 0000000000..af48149920 --- /dev/null +++ b/third_party/lisp/prove.nix @@ -0,0 +1,29 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.prove; +in depot.nix.buildLisp.library { + name = "prove"; + + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.cl-ansi-text + depot.third_party.lisp.cl-colors + depot.third_party.lisp.cl-ppcre + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = [ + "${src}/src/color.lisp" + "${src}/src/output.lisp" + "${src}/src/asdf.lisp" + "${src}/src/report.lisp" + "${src}/src/reporter.lisp" + "${src}/src/reporter/fiveam.lisp" + "${src}/src/reporter/list.lisp" + "${src}/src/reporter/dot.lisp" + "${src}/src/reporter/tap.lisp" + "${src}/src/suite.lisp" + "${src}/src/test.lisp" + "${src}/src/prove.lisp" + ]; +} diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix index 51728c7646..f7146ba93f 100644 --- a/third_party/lisp/puri.nix +++ b/third_party/lisp/puri.nix @@ -1,15 +1,10 @@ # Portable URI library -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "http://git.kpe.io/puri.git"; - rev = "ef5afb9e5286c8e952d4344f019c1a636a717b97"; -}; +let src = with pkgs; srcOnly lispPackages.puri; in depot.nix.buildLisp.library { name = "puri"; srcs = [ (src + "/src.lisp") ]; } - - diff --git a/third_party/lisp/qbase64/coreutils-base64.patch b/third_party/lisp/qbase64/coreutils-base64.patch new file mode 100644 index 0000000000..5a2f2a9f08 --- /dev/null +++ b/third_party/lisp/qbase64/coreutils-base64.patch @@ -0,0 +1,13 @@ +diff --git a/qbase64-test.lisp b/qbase64-test.lisp +index 310fdf3..b92abb5 100644 +--- a/qbase64-test.lisp ++++ b/qbase64-test.lisp +@@ -14,7 +14,7 @@ + (with-open-temporary-file (tmp :direction :output :element-type '(unsigned-byte 8)) + (write-sequence bytes tmp) + (force-output tmp) +- (let* ((encoded (uiop:run-program `("base64" "-b" ,(format nil "~A" linebreak) "-i" ,(namestring tmp)) :output (if (zerop linebreak) '(:string :stripped t) :string))) ++ (let* ((encoded (uiop:run-program `("base64" "-w" ,(format nil "~A" linebreak) ,(namestring tmp)) :output (if (zerop linebreak) '(:string :stripped t) :string) :error-output *error-output*)) + (length (length encoded))) + (cond ((and (> length 1) + (string= (subseq encoded (- length 2)) diff --git a/third_party/lisp/qbase64/default.nix b/third_party/lisp/qbase64/default.nix new file mode 100644 index 0000000000..40a93e04f0 --- /dev/null +++ b/third_party/lisp/qbase64/default.nix @@ -0,0 +1,57 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + src = pkgs.fetchFromGitHub { + owner = "chaitanyagupta"; + repo = "qbase64"; + rev = "4ac193ed6b35a867ca453ed74acc128c9a077407"; + sha256 = "06daqqfdd51wkx0pyxgz7zq4ibzsqsgn3qs04jabx67gyybgnmjm"; + }; + + patches = [ + # qbase64 expects macOS base64 + ./coreutils-base64.patch + ]; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); + +in + +depot.nix.buildLisp.library { + name = "qbase64"; + + srcs = getSrcs [ + "package.lisp" + "utils.lisp" + "stream-utils.lisp" + "qbase64.lisp" + ]; + + deps = [ + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.metabang-bind + ]; + + tests = { + name = "qbase64-tests"; + + srcs = getSrcs [ + "qbase64-test.lisp" + ]; + + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + depot.third_party.lisp.fiveam + depot.third_party.lisp.cl-fad + ]; + + expression = '' + (fiveam:run! '(qbase64-test::encoder 'qbase64-test::decoder)) + ''; + }; +} diff --git a/third_party/lisp/restas.nix b/third_party/lisp/restas.nix deleted file mode 100644 index 8a0b5f907f..0000000000 --- a/third_party/lisp/restas.nix +++ /dev/null @@ -1,38 +0,0 @@ -{ 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" - ]; - -} diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix index 8288094904..b82a490c9d 100644 --- a/third_party/lisp/rfc2388.nix +++ b/third_party/lisp/rfc2388.nix @@ -1,12 +1,7 @@ # Implementation of RFC2388 (multipart/form-data) -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "jdz"; - repo = "rfc2388"; - rev = "591bcf7e77f2c222c43953a80f8c297751dc0c4e"; - sha256 = "0phh5n3clhl9ji8jaxrajidn22d3f0aq87mlbfkkxlnx2pnw694k"; -}; +let src = with pkgs; srcOnly lispPackages.rfc2388; in depot.nix.buildLisp.library { name = "rfc2388"; diff --git a/third_party/lisp/routes.nix b/third_party/lisp/routes.nix index 61c6749660..fc7d4e3067 100644 --- a/third_party/lisp/routes.nix +++ b/third_party/lisp/routes.nix @@ -2,14 +2,26 @@ let - src = pkgs.fetchFromGitHub { - owner = "archimag"; - repo = "cl-routes"; - rev = "1b79e85aa653e1ec87e21ca745abe51547866fa9"; - sha256 = "1zpk3cp2v8hm50ppjl10yxr437vv4552r8hylvizglzrq2ibsbr1"; + 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 { +in +depot.nix.buildLisp.library { name = "routes"; deps = with depot.third_party.lisp; [ @@ -24,5 +36,4 @@ in depot.nix.buildLisp.library { "route.lisp" "mapper.lisp" ]; - } diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix index aebd7c3f7b..9c4da4a02b 100644 --- a/third_party/lisp/s-sysdeps.nix +++ b/third_party/lisp/s-sysdeps.nix @@ -1,12 +1,7 @@ # A Common Lisp abstraction layer over platform dependent functionality. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = depot.third_party.fetchFromGitHub { - owner = "svenvc"; - repo = "s-sysdeps"; - rev = "d28246b5dffef9e73a0e0e6cfbc4e878006fe34d"; - sha256 = "14b69b81yrxmjlvmm3lfxk04x5v7hqz4fql121334wh72czznfh9"; -}; +let src = with pkgs; srcOnly lispPackages.s-sysdeps; in depot.nix.buildLisp.library { name = "s-sysdeps"; @@ -14,4 +9,10 @@ in depot.nix.buildLisp.library { "${src}/src/package.lisp" "${src}/src/sysdeps.lisp" ]; + + deps = with depot.third_party.lisp; [ + bordeaux-threads + usocket + usocket-server + ]; } diff --git a/third_party/lisp/s-xml/.gitignore b/third_party/lisp/s-xml/.gitignore deleted file mode 100644 index 40caffa8e2..0000000000 --- a/third_party/lisp/s-xml/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -# 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/0001-fix-definition-order-in-xml.lisp.patch b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch new file mode 100644 index 0000000000..9e5838c3c5 --- /dev/null +++ b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch @@ -0,0 +1,26 @@ +From 789dc38399f4039b114de28384c149721d66b030 Mon Sep 17 00:00:00 2001 +From: Vincent Ambo <mail@tazj.in> +Date: Thu, 16 Dec 2021 00:48:04 +0300 +Subject: [PATCH] fix definition order in xml.lisp + +--- + src/xml.lisp | 3 +++ + 1 file changed, 3 insertions(+) + +diff --git a/src/xml.lisp b/src/xml.lisp +index 39c9b63..3232491 100644 +--- a/src/xml.lisp ++++ b/src/xml.lisp +@@ -19,6 +19,9 @@ + + ;;; error reporting + ++(defvar *ignore-namespaces* nil ++ "When t, namespaces are ignored like in the old version of S-XML") ++ + (define-condition xml-parser-error (error) + ((message :initarg :message :reader xml-parser-error-message) + (args :initarg :args :reader xml-parser-error-args) +-- +2.34.0 + diff --git a/third_party/lisp/s-xml/ChangeLog b/third_party/lisp/s-xml/ChangeLog deleted file mode 100644 index ac196619c0..0000000000 --- a/third_party/lisp/s-xml/ChangeLog +++ /dev/null @@ -1,66 +0,0 @@ -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 deleted file mode 100644 index 0c7292ea9f..0000000000 --- a/third_party/lisp/s-xml/Makefile +++ /dev/null @@ -1,35 +0,0 @@ -# $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 index 82b6317f37..486e1c1ac8 100644 --- a/third_party/lisp/s-xml/default.nix +++ b/third_party/lisp/s-xml/default.nix @@ -1,17 +1,25 @@ # XML serialiser for Common Lisp. -# -# This system was imported from a Quicklisp tarball at 's-xml-20150608'. -{ depot, ... }: +{ depot, pkgs, ... }: +let + src = pkgs.applyPatches { + name = "s-xml-source"; + src = pkgs.lispPackages.s-xml.src; + + patches = [ + ./0001-fix-definition-order-in-xml.lisp.patch + ]; + }; +in 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 + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "xml.lisp" + "dom.lisp" + "lxml-dom.lisp" + "sxml-dom.lisp" + "xml-struct-dom.lisp" ]; } diff --git a/third_party/lisp/s-xml/examples/counter.lisp b/third_party/lisp/s-xml/examples/counter.lisp deleted file mode 100644 index b26453e6ea..0000000000 --- a/third_party/lisp/s-xml/examples/counter.lisp +++ /dev/null @@ -1,47 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index a0befe2cbb..0000000000 --- a/third_party/lisp/s-xml/examples/echo.lisp +++ /dev/null @@ -1,64 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 41d858b4a8..0000000000 --- a/third_party/lisp/s-xml/examples/remove-markup.lisp +++ /dev/null @@ -1,21 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index c8a3eaec1f..0000000000 --- a/third_party/lisp/s-xml/examples/tracer.lisp +++ /dev/null @@ -1,57 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 651f5e5844..0000000000 --- a/third_party/lisp/s-xml/s-xml.asd +++ /dev/null @@ -1,49 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 74d1c371db..0000000000 --- a/third_party/lisp/s-xml/src/dom.lisp +++ /dev/null @@ -1,75 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index d43df6cf81..0000000000 --- a/third_party/lisp/s-xml/src/lxml-dom.lisp +++ /dev/null @@ -1,83 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index f90f0f49a1..0000000000 --- a/third_party/lisp/s-xml/src/package.lisp +++ /dev/null @@ -1,46 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index c9e0f9e0db..0000000000 --- a/third_party/lisp/s-xml/src/sxml-dom.lisp +++ /dev/null @@ -1,76 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 7037388915..0000000000 --- a/third_party/lisp/s-xml/src/xml-struct-dom.lisp +++ /dev/null @@ -1,125 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 8a2076985a..0000000000 --- a/third_party/lisp/s-xml/src/xml.lisp +++ /dev/null @@ -1,702 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 91d78707b8..0000000000 --- a/third_party/lisp/s-xml/test/ant-build-file.xml +++ /dev/null @@ -1,252 +0,0 @@ -<!-- $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 deleted file mode 100644 index 910e6326ea..0000000000 --- a/third_party/lisp/s-xml/test/plist.xml +++ /dev/null @@ -1,38 +0,0 @@ -<?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 deleted file mode 100644 index 08ad9424e3..0000000000 --- a/third_party/lisp/s-xml/test/simple.xml +++ /dev/null @@ -1,5 +0,0 @@ -<?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 deleted file mode 100644 index 248e1e4b90..0000000000 --- a/third_party/lisp/s-xml/test/test-lxml-dom.lisp +++ /dev/null @@ -1,86 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 7164d5ef0d..0000000000 --- a/third_party/lisp/s-xml/test/test-sxml-dom.lisp +++ /dev/null @@ -1,76 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index f5ee1cc925..0000000000 --- a/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp +++ /dev/null @@ -1,84 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index daef58ea46..0000000000 --- a/third_party/lisp/s-xml/test/test-xml.lisp +++ /dev/null @@ -1,86 +0,0 @@ -;;;; -*- 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 deleted file mode 100644 index 79f3ae3bad..0000000000 --- a/third_party/lisp/s-xml/test/xhtml-page.xml +++ /dev/null @@ -1,271 +0,0 @@ -<!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/split-sequence.nix b/third_party/lisp/split-sequence.nix index 105646386f..4e8f723c31 100644 --- a/third_party/lisp/split-sequence.nix +++ b/third_party/lisp/split-sequence.nix @@ -1,10 +1,7 @@ # split-sequence is a library for, well, splitting sequences apparently. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/sharplispers/split-sequence.git"; - rev = "41c0fc79a5a2871d16e5727969a8f699ef44d791"; -}; +let src = with pkgs; srcOnly lispPackages.split-sequence; in depot.nix.buildLisp.library { name = "split-sequence"; srcs = map (f: src + ("/" + f)) [ diff --git a/third_party/lisp/str.nix b/third_party/lisp/str.nix new file mode 100644 index 0000000000..556f9cc307 --- /dev/null +++ b/third_party/lisp/str.nix @@ -0,0 +1,49 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.str; +in +buildLisp.library { + name = "str"; + + deps = with depot.third_party.lisp; [ + { + sbcl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + cl-ppcre + cl-ppcre.unicode + cl-change-case + ]; + + srcs = [ + (pkgs.runCommand "str.lisp" { } '' + substitute ${src}/str.lisp $out \ + --replace-fail \ + '(asdf:component-version (asdf:find-system "str"))' \ + '"${pkgs.lispPackages.str.meta.version}"' + '') + ]; + + brokenOn = [ + "ccl" # In REPLACE-USING: Shouldn't assign to variable I + ]; + + tests = { + name = "str-test"; + srcs = [ (src + "/test/test-str.lisp") ]; + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + depot.third_party.lisp.prove + depot.third_party.lisp.fiveam + ]; + + expression = '' + (fiveam:run! 'str::test-str) + ''; + }; +} diff --git a/third_party/lisp/trivial-backtrace.nix b/third_party/lisp/trivial-backtrace.nix new file mode 100644 index 0000000000..27949e8be1 --- /dev/null +++ b/third_party/lisp/trivial-backtrace.nix @@ -0,0 +1,15 @@ +# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-backtrace; +in depot.nix.buildLisp.library { + name = "trivial-backtrace"; + + srcs = map (f: src + ("/dev/" + f)) [ + "packages.lisp" + "utilities.lisp" + "backtrace.lisp" + "map-backtrace.lisp" + "fallback.lisp" + ]; +} diff --git a/third_party/lisp/trivial-backtrace/.gitignore b/third_party/lisp/trivial-backtrace/.gitignore deleted file mode 100644 index 391b10e5db..0000000000 --- a/third_party/lisp/trivial-backtrace/.gitignore +++ /dev/null @@ -1,15 +0,0 @@ -# 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 deleted file mode 100644 index 3798a6664a..0000000000 --- a/third_party/lisp/trivial-backtrace/COPYING +++ /dev/null @@ -1,25 +0,0 @@ -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 deleted file mode 100644 index bdd057cade..0000000000 --- a/third_party/lisp/trivial-backtrace/default.nix +++ /dev/null @@ -1,14 +0,0 @@ -# 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 deleted file mode 100644 index aa3951e30f..0000000000 --- a/third_party/lisp/trivial-backtrace/dev/backtrace.lisp +++ /dev/null @@ -1,127 +0,0 @@ -(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 deleted file mode 100644 index 40a5219824..0000000000 --- a/third_party/lisp/trivial-backtrace/dev/fallback.lisp +++ /dev/null @@ -1,10 +0,0 @@ -(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 deleted file mode 100644 index 43eddda475..0000000000 --- a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp +++ /dev/null @@ -1,105 +0,0 @@ -(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 deleted file mode 100644 index 2be26a5a87..0000000000 --- a/third_party/lisp/trivial-backtrace/dev/mucking.lisp +++ /dev/null @@ -1,75 +0,0 @@ -(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 deleted file mode 100644 index 2da49d3d9b..0000000000 --- a/third_party/lisp/trivial-backtrace/dev/packages.lisp +++ /dev/null @@ -1,13 +0,0 @@ -(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 deleted file mode 100644 index b0a249867a..0000000000 --- a/third_party/lisp/trivial-backtrace/dev/utilities.lisp +++ /dev/null @@ -1,104 +0,0 @@ -(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 deleted file mode 100644 index 0f22312080..0000000000 --- a/third_party/lisp/trivial-backtrace/lift-standard.config +++ /dev/null @@ -1,35 +0,0 @@ -;;; 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 deleted file mode 100644 index 7dc3eae576..0000000000 --- a/third_party/lisp/trivial-backtrace/test/packages.lisp +++ /dev/null @@ -1,5 +0,0 @@ -(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 deleted file mode 100644 index a46b3a1966..0000000000 --- a/third_party/lisp/trivial-backtrace/test/test-setup.lisp +++ /dev/null @@ -1,4 +0,0 @@ -(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 deleted file mode 100644 index 9b32090f13..0000000000 --- a/third_party/lisp/trivial-backtrace/test/tests.lisp +++ /dev/null @@ -1,17 +0,0 @@ -(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 deleted file mode 100644 index cb088434a2..0000000000 --- a/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd +++ /dev/null @@ -1,22 +0,0 @@ -(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 deleted file mode 100644 index 843b6cc39a..0000000000 --- a/third_party/lisp/trivial-backtrace/trivial-backtrace.asd +++ /dev/null @@ -1,35 +0,0 @@ -(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 deleted file mode 100644 index 93a5df3b91..0000000000 --- a/third_party/lisp/trivial-backtrace/website/source/index.md +++ /dev/null @@ -1,88 +0,0 @@ -{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 deleted file mode 100644 index c5bf3c4ec3..0000000000 --- a/third_party/lisp/trivial-backtrace/website/source/resources/footer.md +++ /dev/null @@ -1,15 +0,0 @@ -<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 deleted file mode 100644 index 2738c47137..0000000000 --- a/third_party/lisp/trivial-backtrace/website/source/resources/header.md +++ /dev/null @@ -1,19 +0,0 @@ -{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 deleted file mode 100644 index a734edfb83..0000000000 --- a/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md +++ /dev/null @@ -1,2 +0,0 @@ -<div id="navigation"> -</div> diff --git a/third_party/lisp/trivial-backtrace/website/website.tmproj b/third_party/lisp/trivial-backtrace/website/website.tmproj deleted file mode 100644 index 01b745ba44..0000000000 --- a/third_party/lisp/trivial-backtrace/website/website.tmproj +++ /dev/null @@ -1,93 +0,0 @@ -<?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 index b7808a2364..02abac54a8 100644 --- a/third_party/lisp/trivial-features.nix +++ b/third_party/lisp/trivial-features.nix @@ -1,12 +1,13 @@ -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/trivial-features/trivial-features.git"; - rev = "b78b2df5d75bdf8fdfc69f0deec0a187d9664b0b"; -}; +let src = with pkgs; srcOnly lispPackages.trivial-features; in depot.nix.buildLisp.library { name = "trivial-features"; srcs = [ - (src + "/src/tf-sbcl.lisp") + { + 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 index e5b3550de7..74224df60d 100644 --- a/third_party/lisp/trivial-garbage.nix +++ b/third_party/lisp/trivial-garbage.nix @@ -1,11 +1,8 @@ # trivial-garbage provides a portable API to finalizers, weak # hash-tables and weak pointers -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/trivial-garbage/trivial-garbage.git"; - rev = "dbc8e35acb0176b9a14fdc1027f5ebea93435a84"; -}; +let src = with pkgs; srcOnly lispPackages.trivial-garbage; 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 index b5722f9a68..62a30f1e94 100644 --- a/third_party/lisp/trivial-gray-streams.nix +++ b/third_party/lisp/trivial-gray-streams.nix @@ -1,10 +1,7 @@ # Portability library for CL gray streams. -{ depot, ... }: +{ depot, pkgs, ... }: -let src = builtins.fetchGit { - url = "https://github.com/trivial-gray-streams/trivial-gray-streams.git"; - rev = "ebd59b1afed03b9dc8544320f8f432fdf92ab010"; -}; +let src = with pkgs; srcOnly lispPackages.trivial-gray-streams; in depot.nix.buildLisp.library { name = "trivial-gray-streams"; srcs = [ diff --git a/third_party/lisp/trivial-indent.nix b/third_party/lisp/trivial-indent.nix index 65d98604d7..70a6e19d48 100644 --- a/third_party/lisp/trivial-indent.nix +++ b/third_party/lisp/trivial-indent.nix @@ -1,13 +1,6 @@ - { depot, pkgs, ... }: -let - src = pkgs.fetchFromGitHub { - owner = "Shinmera"; - repo = "trivial-indent"; - rev = "2d016941751647c6cc5bd471751c2cf68861c94a"; - sha256 = "1sj90nqz17w4jq0ixz00gb9g5g6d2s7l8r17zdby27gxxh51w266"; - }; +let src = with pkgs; srcOnly lispPackages.trivial-indent; in depot.nix.buildLisp.library { name = "trivial-indent"; diff --git a/third_party/lisp/trivial-ldap.nix b/third_party/lisp/trivial-ldap.nix index aed651239d..c85fe2accb 100644 --- a/third_party/lisp/trivial-ldap.nix +++ b/third_party/lisp/trivial-ldap.nix @@ -1,15 +1,17 @@ { depot, pkgs, ... }: -let src = pkgs.fetchFromGitHub { +let + src = pkgs.fetchFromGitHub { owner = "rwiker"; repo = "trivial-ldap"; rev = "3b8f1ff85f29ea63e6ab2d0d27029d68b046faf8"; sha256 = "1zaa4wnk5y5ff211pkg6dl27j4pjwh56hq0246slxsdxv6kvp1z9"; }; -in depot.nix.buildLisp.library { +in +depot.nix.buildLisp.library { name = "trivial-ldap"; - deps = with pkgs.lisp; [ + deps = with depot.third_party.lisp; [ usocket cl-plus-ssl cl-yacc @@ -19,4 +21,8 @@ in depot.nix.buildLisp.library { "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 index c4b21045c5..b097a3d0ee 100644 --- a/third_party/lisp/trivial-mimes.nix +++ b/third_party/lisp/trivial-mimes.nix @@ -1,23 +1,25 @@ { depot, pkgs, ... }: let - src = pkgs.fetchFromGitHub { - owner = "Shinmera"; - repo = "trivial-mimes"; - rev = "a741fc2f567a4f86b853fd4677d75e62c03e51d9"; - sha256 = "00kcm17q5plpzdj1qwg83ldhxksilgpcdkf3m9azxcdr968xs9di"; - }; + src = with pkgs; srcOnly lispPackages.trivial-mimes; - mime-types = pkgs.runCommand "mime-types.lisp" {} '' + mime-types = pkgs.runCommand "mime-types.lisp" { } '' substitute ${src}/mime-types.lisp $out \ - --replace /etc/mime.types ${src}/mime.types + --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 { +in +depot.nix.buildLisp.library { name = "trivial-mimes"; deps = [ - (depot.nix.buildLisp.bundled "uiop") + { + 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 index 664be63f06..f98c029d36 100644 --- a/third_party/lisp/uax-15.nix +++ b/third_party/lisp/uax-15.nix @@ -3,43 +3,40 @@ 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 { + src = with pkgs; srcOnly lispPackages.uax-15; +in +depot.nix.buildLisp.library { name = "uax-15"; - deps = with pkgs.lisp; [ + deps = with depot.third_party.lisp; [ split-sequence cl-ppcre - (bundled "uiop") (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" {} '' + + # uax-15 has runtime data files that need to have their references + # replaced with store paths. + # + # additionally there are some wonky variable usages of variables + # that are never defined, for which we patch in defvar statements. + (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*)' + -e '10i(defvar *canonical-decomp-map*)' \ + -e '10i(defvar *compatible-decomp-map*)' \ + -e '10i(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 index 99117d8beb..2482961132 100644 --- a/third_party/lisp/unix-opts.nix +++ b/third_party/lisp/unix-opts.nix @@ -1,13 +1,8 @@ # unix-opts is a portable command line argument parser -{ depot, ...}: +{ depot, pkgs, ... }: -let - src = depot.third_party.fetchFromGitHub { - owner = "libre-man"; - repo = "unix-opts"; - rev = "b805050b074bd860edd18cfc8776fdec666ec36e"; - sha256 = "0j93dkc9f77wz1zfspm7q1scx6wwbm6jhk8vl2rm6bfd0n8scxla"; - }; + +let src = with pkgs; srcOnly lispPackages.unix-opts; in depot.nix.buildLisp.library { name = "unix-opts"; diff --git a/third_party/lisp/usocket-server.nix b/third_party/lisp/usocket-server.nix new file mode 100644 index 0000000000..5d6d04535f --- /dev/null +++ b/third_party/lisp/usocket-server.nix @@ -0,0 +1,19 @@ +# Universal socket library for Common Lisp (server side) +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.usocket-server; +in +buildLisp.library { + name = "usocket-server"; + + deps = with depot.third_party.lisp; [ + usocket + bordeaux-threads + ]; + + srcs = [ + "${src}/server.lisp" + ]; +} diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix index 920c41c58d..589a3a0cfc 100644 --- a/third_party/lisp/usocket.nix +++ b/third_party/lisp/usocket.nix @@ -1,19 +1,18 @@ # Usocket is a portable socket library -{ depot, ... }: +{ depot, pkgs, ... }: -with depot.nix; - -let src = depot.third_party.fetchFromGitHub { - owner = "usocket"; - repo = "usocket"; - rev = "fdf4fd1e0051ce83340ccfbbc8a43a462bb19cf2"; - sha256 = "0x746wr2324l6bn7skqzgkzcbj5kd0zp2ck0c8rldrw0rzabg826"; -}; -in buildLisp.library { +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.usocket; +in +buildLisp.library { name = "usocket"; deps = with depot.third_party.lisp; [ (buildLisp.bundled "asdf") - (buildLisp.bundled "sb-bsd-sockets") + { + ecl = buildLisp.bundled "sb-bsd-sockets"; + sbcl = buildLisp.bundled "sb-bsd-sockets"; + } split-sequence ]; @@ -32,6 +31,16 @@ in buildLisp.library { "package.lisp" "usocket.lisp" "condition.lisp" - "backend/sbcl.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"; } ]); } |