diff options
Diffstat (limited to 'third_party/lisp')
120 files changed, 10515 insertions, 0 deletions
diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS new file mode 100644 index 000000000000..8dd1b65b9bc4 --- /dev/null +++ b/third_party/lisp/OWNERS @@ -0,0 +1,2 @@ +eta +grfn diff --git a/third_party/lisp/alexandria.nix b/third_party/lisp/alexandria.nix new file mode 100644 index 000000000000..b522e2d142c1 --- /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/anaphora.nix b/third_party/lisp/anaphora.nix new file mode 100644 index 000000000000..c079943e6725 --- /dev/null +++ b/third_party/lisp/anaphora.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.anaphora; +in depot.nix.buildLisp.library { + name = "anaphora"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "early.lisp" + "symbolic.lisp" + "anaphora.lisp" + ]; +} diff --git a/third_party/lisp/asdf-flv/.gitattributes b/third_party/lisp/asdf-flv/.gitattributes new file mode 100644 index 000000000000..2b45716e4709 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitattributes @@ -0,0 +1,2 @@ +.gitignore export-ignore +.gitattributes export-ignore diff --git a/third_party/lisp/asdf-flv/.gitignore b/third_party/lisp/asdf-flv/.gitignore new file mode 100644 index 000000000000..bdf4ad2ae6dd --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitignore @@ -0,0 +1,3 @@ +sbcl-*/ +cmu-*/ +openmcl-*/ diff --git a/third_party/lisp/asdf-flv/Makefile b/third_party/lisp/asdf-flv/Makefile new file mode 100644 index 000000000000..b4c74feefe82 --- /dev/null +++ b/third_party/lisp/asdf-flv/Makefile @@ -0,0 +1,77 @@ +### Makefile --- Toplevel directory + +## Copyright (C) 2011, 2015 Didier Verna + +## Author: Didier Verna <didier@didierverna.net> + +## This file is part of ASDF-FLV. + +## Copying and distribution of this file, with or without modification, +## are permitted in any medium without royalty provided the copyright +## notice and this notice are preserved. This file is offered as-is, +## without any warranty. + + +### Commentary: + +## Contents management by FCM version 0.1. + + +### Code: + +PROJECT := asdf-flv +VERSION := 2.1 + +W3DIR := $(HOME)/www/software/lisp/$(PROJECT) + +DIST_NAME := $(PROJECT)-$(VERSION) +TARBALL := $(DIST_NAME).tar.gz +SIGNATURE := $(TARBALL).asc + + +all: + +clean: + -rm *~ + +distclean: clean + -rm *.tar.gz *.tar.gz.asc + +tag: + git tag -a -m 'Version $(VERSION)' 'version-$(VERSION)' + +tar: $(TARBALL) +gpg: $(SIGNATURE) +dist: tar gpg + +install-www: dist + -install -m 644 $(TARBALL) "$(W3DIR)/attic/" + -install -m 644 $(SIGNATURE) "$(W3DIR)/attic/" + echo "\ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz\", \ + contents (\"Dernire version\", \"Latest version\")); ?> \ +| \ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz.asc\", \ + contents (\"Signature GPG\", \"GPG Signature\")); ?>" \ + > "$(W3DIR)/latest.txt" + chmod 644 "$(W3DIR)/latest.txt" + cd "$(W3DIR)" \ + && ln -fs attic/$(TARBALL) latest.tar.gz \ + && ln -fs attic/$(SIGNATURE) latest.tar.gz.asc + +update-version: + perl -pi -e 's/:version ".*"/:version "$(VERSION)"/' \ + net.didierverna.$(PROJECT).asd + +$(TARBALL): + git archive --format=tar --prefix=$(DIST_NAME)/ \ + --worktree-attributes HEAD \ + | gzip -c > $@ + +$(SIGNATURE): $(TARBALL) + gpg -b -a $< + + +.PHONY: all clean distclean tag tar gpg dist install-www update-version + +### Makefile ends here diff --git a/third_party/lisp/asdf-flv/README.md b/third_party/lisp/asdf-flv/README.md new file mode 100644 index 000000000000..7ccdd1888163 --- /dev/null +++ b/third_party/lisp/asdf-flv/README.md @@ -0,0 +1,7 @@ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like `*PACKAGE*` and `*READTABLE*` with respect to `LOAD` and +`COMPILE-FILE`: a new dynamic binding is created before processing the file, +so that any modification to the variable essentially becomes file-local. + +In order to make one or several variables file-local, use the macros +`SET-FILE-LOCAL-VARIABLE(S)`. diff --git a/third_party/lisp/asdf-flv/asdf-flv.lisp b/third_party/lisp/asdf-flv/asdf-flv.lisp new file mode 100644 index 000000000000..76c6845b82b3 --- /dev/null +++ b/third_party/lisp/asdf-flv/asdf-flv.lisp @@ -0,0 +1,64 @@ +;;; asdf-flv.lisp --- Implementation + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :net.didierverna.asdf-flv) + + +(defvar *file-local-variables* () + "List of file-local special variables.") + + +(defun make-variable-file-local (symbol) + "Make special variable named by SYMBOL have a file-local value." + (pushnew symbol *file-local-variables*)) + +(defmacro set-file-local-variable (symbol) + "Set special variable named by SYMBOL as file-local. +SYMBOL need not be quoted." + `(make-variable-file-local ',symbol)) + +(defun make-variables-file-local (&rest symbols) + "Make special variables named by SYMBOLS have a file-local value." + (dolist (symbol symbols) + (pushnew symbol *file-local-variables*))) + +(defmacro set-file-local-variables (&rest symbols) + "Set special variables named by SYMBOLS as file-local. +SYMBOLS need not be quoted." + `(make-variables-file-local ,@(mapcar (lambda (symbol) (list 'quote symbol)) + symbols))) + + +(defmethod asdf:perform :around + ((operation asdf:load-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +(defmethod asdf:perform :around + ((operation asdf:compile-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +;;; asdf-flv.lisp ends here diff --git a/third_party/lisp/asdf-flv/default.nix b/third_party/lisp/asdf-flv/default.nix new file mode 100644 index 000000000000..e8ec4aa8f85c --- /dev/null +++ b/third_party/lisp/asdf-flv/default.nix @@ -0,0 +1,13 @@ +# Imported from https://github.com/didierverna/asdf-flv +{ depot, ... }: + +with depot.nix; +buildLisp.library { + name = "asdf-flv"; + deps = [ (buildLisp.bundled "asdf") ]; + + srcs = [ + ./package.lisp + ./asdf-flv.lisp + ]; +} diff --git a/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd new file mode 100644 index 000000000000..41202746d019 --- /dev/null +++ b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd @@ -0,0 +1,43 @@ +;;; net.didierverna.asdf-flv.asd --- ASDF system definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(asdf:defsystem :net.didierverna.asdf-flv + :long-name "ASDF File Local Variables" + :description "ASDF extension to provide support for file-local variables." + :long-description "\ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like *PACKAGE* and *READTABLE* with respect to LOAD and +COMPILE-FILE: a new dynamic binding is created before processing the file, so +that any modification to the variable becomes essentially file-local. + +In order to make one or several variables file-local, use the macros +SET-FILE-LOCAL-VARIABLE(S)." + :author "Didier Verna" + :mailto "didier@didierverna.net" + :homepage "http://www.lrde.epita.fr/~didier/software/lisp/misc.php#asdf-flv" + :source-control "https://github.com/didierverna/asdf-flv" + :license "GNU All Permissive" + :version "2.1" + :serial t + :components ((:file "package") + (:file "asdf-flv"))) + +;;; net.didierverna.asdf-flv.asd ends here diff --git a/third_party/lisp/asdf-flv/package.lisp b/third_party/lisp/asdf-flv/package.lisp new file mode 100644 index 000000000000..1d7fb2bab43d --- /dev/null +++ b/third_party/lisp/asdf-flv/package.lisp @@ -0,0 +1,28 @@ +;;; package.lisp --- Package definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :cl-user) + +(defpackage :net.didierverna.asdf-flv + (:use :cl) + (:export :set-file-local-variable :set-file-local-variables)) + +;;; package.lisp ends here diff --git a/third_party/lisp/babel.nix b/third_party/lisp/babel.nix new file mode 100644 index 000000000000..ae7c5dd23d18 --- /dev/null +++ b/third_party/lisp/babel.nix @@ -0,0 +1,31 @@ +# Babel is an encoding conversion library for Common Lisp. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.babel; +in depot.nix.buildLisp.library { + name = "babel"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.trivial-features + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "packages.lisp" + "encodings.lisp" + "enc-ascii.lisp" + "enc-ebcdic.lisp" + "enc-ebcdic-int.lisp" + "enc-iso-8859.lisp" + "enc-unicode.lisp" + "enc-cp1251.lisp" + "enc-cp1252.lisp" + "jpn-table.lisp" + "enc-jpn.lisp" + "enc-gbk.lisp" + "enc-koi8.lisp" + "external-format.lisp" + "strings.lisp" + "gbk-map.lisp" + "sharp-backslash.lisp" + ]; +} diff --git a/third_party/lisp/bordeaux-threads.nix b/third_party/lisp/bordeaux-threads.nix new file mode 100644 index 000000000000..8a2e09950887 --- /dev/null +++ b/third_party/lisp/bordeaux-threads.nix @@ -0,0 +1,24 @@ +# This library is meant to make writing portable multi-threaded apps +# in Common Lisp simple. +{ depot, pkgs, ... }: + +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 getSrc [ + "pkgdcl.lisp" + "bordeaux-threads.lisp" + ] ++ [ + { + sbcl = getSrc "impl-sbcl.lisp"; + ecl = getSrc "impl-ecl.lisp"; + } + ] ++ map getSrc [ + "default-implementations.lisp" + ]; +} diff --git a/third_party/lisp/cffi.nix b/third_party/lisp/cffi.nix new file mode 100644 index 000000000000..de1d0c2e8ed7 --- /dev/null +++ b/third_party/lisp/cffi.nix @@ -0,0 +1,34 @@ +# CFFI purports to be the Common Foreign Function Interface. +{ depot, pkgs, ... }: + +with depot.nix; +let src = with pkgs; srcOnly lispPackages.cffi; +in buildLisp.library { + name = "cffi"; + deps = with depot.third_party.lisp; [ + alexandria + babel + trivial-features + (buildLisp.bundled "asdf") + ]; + + srcs = [ + { + ecl = src + "/src/cffi-ecl.lisp"; + sbcl = src + "/src/cffi-sbcl.lisp"; + ccl = src + "/src/cffi-openmcl.lisp"; + } + ] ++ map (f: src + ("/src/" + f)) [ + "package.lisp" + "utils.lisp" + "libraries.lisp" + "early-types.lisp" + "types.lisp" + "enum.lisp" + "strings.lisp" + "structures.lisp" + "functions.lisp" + "foreign-vars.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/chipz.nix b/third_party/lisp/chipz.nix new file mode 100644 index 000000000000..59e9914ee1d1 --- /dev/null +++ b/third_party/lisp/chipz.nix @@ -0,0 +1,26 @@ +# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.chipz; +in depot.nix.buildLisp.library { + name = "chipz"; + deps = [ (depot.nix.buildLisp.bundled "asdf") ]; + + srcs = map (f: src + ("/" + f)) [ + "chipz.asd" + "package.lisp" + "constants.lisp" + "conditions.lisp" + "dstate.lisp" + "types-and-tables.lisp" + "crc32.lisp" + "adler32.lisp" + "inflate-state.lisp" + "gzip.lisp" + "zlib.lisp" + "inflate.lisp" + "bzip2.lisp" + "decompress.lisp" + "stream.lisp" + ]; +} diff --git a/third_party/lisp/chunga.nix b/third_party/lisp/chunga.nix new file mode 100644 index 000000000000..d3f50bcb1af8 --- /dev/null +++ b/third_party/lisp/chunga.nix @@ -0,0 +1,22 @@ +# Portable chunked streams for Common Lisp +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.chunga; +in depot.nix.buildLisp.library { + name = "chunga"; + deps = with depot.third_party.lisp; [ + trivial-gray-streams + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "known-words.lisp" + "conditions.lisp" + "read.lisp" + "streams.lisp" + "input.lisp" + "output.lisp" + ]; +} diff --git a/third_party/lisp/cl-ansi-text.nix b/third_party/lisp/cl-ansi-text.nix new file mode 100644 index 000000000000..0e3401524755 --- /dev/null +++ b/third_party/lisp/cl-ansi-text.nix @@ -0,0 +1,16 @@ +# Enables ANSI colors for printing. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-ansi-text; +in depot.nix.buildLisp.library { + name = "cl-ansi-text"; + deps = with depot.third_party.lisp; [ + alexandria + cl-colors2 + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "cl-ansi-text.lisp" + "define-colors.lisp" + ]; +} diff --git a/third_party/lisp/cl-base64.nix b/third_party/lisp/cl-base64.nix new file mode 100644 index 000000000000..08055a047119 --- /dev/null +++ b/third_party/lisp/cl-base64.nix @@ -0,0 +1,14 @@ +# Base64 encoding for Common Lisp +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-base64; +in depot.nix.buildLisp.library { + name = "cl-base64"; + srcs = [ + (src + "/package.lisp") + (src + "/encode.lisp") + (src + "/decode.lisp") + ]; +} + + diff --git a/third_party/lisp/cl-colors.nix b/third_party/lisp/cl-colors.nix new file mode 100644 index 000000000000..b51e4d46a747 --- /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 new file mode 100644 index 000000000000..34201bc2faa0 --- /dev/null +++ b/third_party/lisp/cl-colors2.nix @@ -0,0 +1,18 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-colors2; +in depot.nix.buildLisp.library { + name = "cl-colors2"; + deps = with depot.third_party.lisp; [ + alexandria + cl-ppcre + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "colors.lisp" + "colornames-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 000000000000..e53cb2dfce42 --- /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 new file mode 100644 index 000000000000..9350abe2e3a3 --- /dev/null +++ b/third_party/lisp/cl-fad.nix @@ -0,0 +1,27 @@ +# Portable pathname library +{ depot, pkgs, ... }: + +with depot.nix; + +let src = with pkgs; srcOnly lispPackages.cl-fad; +in buildLisp.library { + name = "cl-fad"; + + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + { + sbcl = buildLisp.bundled "sb-posix"; + } + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + ] ++ [ + { ccl = "${src}/openmcl.lisp"; } + ] ++ map (f: src + ("/" + f)) [ + "fad.lisp" + "path.lisp" + "temporary-files.lisp" + ]; +} diff --git a/third_party/lisp/cl-json.nix b/third_party/lisp/cl-json.nix new file mode 100644 index 000000000000..6b82fac772d4 --- /dev/null +++ b/third_party/lisp/cl-json.nix @@ -0,0 +1,53 @@ +# JSON encoder & decoder +{ depot, pkgs, ... }: + +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" ] ++ + (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 new file mode 100644 index 000000000000..dc0a95944fe7 --- /dev/null +++ b/third_party/lisp/cl-plus-ssl.nix @@ -0,0 +1,50 @@ +# Common Lisp bindings to OpenSSL +{ depot, pkgs, ... }: + +with depot.nix; + +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 + bordeaux-threads + cffi + flexi-streams + trivial-features + trivial-garbage + trivial-gray-streams + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + { sbcl = buildLisp.bundled "sb-posix"; } + ]; + + native = [ pkgs.openssl ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "reload.lisp" + "conditions.lisp" + "ffi.lisp" + "x509.lisp" + "ffi-buffer-all.lisp" + "ffi-buffer.lisp" + "streams.lisp" + "bio.lisp" + "random.lisp" + "context.lisp" + "verify-hostname.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/cl-ppcre.nix b/third_party/lisp/cl-ppcre.nix new file mode 100644 index 000000000000..561e306191ca --- /dev/null +++ b/third_party/lisp/cl-ppcre.nix @@ -0,0 +1,27 @@ +# cl-ppcre is a Common Lisp regular expression library. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-ppcre; +in depot.nix.buildLisp.library { + name = "cl-ppcre"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "errors.lisp" + "charset.lisp" + "charmap.lisp" + "chartest.lisp" + "lexer.lisp" + "parser.lisp" + "regex-class.lisp" + "regex-class-util.lisp" + "convert.lisp" + "optimize.lisp" + "closures.lisp" + "repetition-closures.lisp" + "scanner.lisp" + "api.lisp" + ]; +} diff --git a/third_party/lisp/cl-prevalence.nix b/third_party/lisp/cl-prevalence.nix new file mode 100644 index 000000000000..188cbc686d28 --- /dev/null +++ b/third_party/lisp/cl-prevalence.nix @@ -0,0 +1,25 @@ +# cl-prevalence is an implementation of object prevalence for CL (i.e. +# an in-memory database) +{ depot, pkgs, ... }: + +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 + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "serialization/serialization.lisp" + "serialization/xml.lisp" + "serialization/sexp.lisp" + "prevalence.lisp" + "managed-prevalence.lisp" + "master-slave.lisp" + "blob.lisp" + ]; +} diff --git a/third_party/lisp/cl-smtp.nix b/third_party/lisp/cl-smtp.nix new file mode 100644 index 000000000000..7ab9bea59ff5 --- /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 new file mode 100644 index 000000000000..815d99c2dc8e --- /dev/null +++ b/third_party/lisp/cl-unicode.nix @@ -0,0 +1,80 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) sbcl runCommand writeText; + inherit (depot.nix.buildLisp) bundled; + + src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "cl-unicode"; + rev = "8073fc5634c9d4802888ac03abf11dfe383e16fa"; + sha256 = "0ykx2s9lqfl74p1px0ik3l2izd1fc9jd1b4ra68s5x34rvjy0hza"; + }; + + cl-unicode-base = depot.nix.buildLisp.library { + name = "cl-unicode-base"; + deps = with depot.third_party.lisp; [ + cl-ppcre + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + ]; + }; + + cl-unicode-build = depot.nix.buildLisp.program { + name = "cl-unicode-build"; + deps = with depot.third_party.lisp; [ + cl-unicode-base + flexi-streams + { + ecl = bundled "asdf"; + default = bundled "uiop"; + } + ]; + + srcs = (map (f: src + ("/build/" + f)) [ + "util.lisp" + "char-info.lisp" + "read.lisp" + ]) ++ [ + (runCommand "dump.lisp" { } '' + substitute ${src}/build/dump.lisp $out \ + --replace ':defaults *this-file*' ":defaults (uiop:getcwd)" + '') + + (writeText "export-create-source-files.lisp" '' + (in-package :cl-unicode) + (export 'create-source-files) + '') + ]; + + main = "cl-unicode:create-source-files"; + }; + + + generated = runCommand "cl-unicode-generated" { } '' + mkdir -p $out/build + mkdir -p $out/test + cd $out/build + pwd + ${cl-unicode-build}/bin/cl-unicode-build + ''; + +in +depot.nix.buildLisp.library { + name = "cl-unicode"; + deps = [ cl-unicode-base ]; + srcs = [ + "${src}/conditions.lisp" + "${generated}/lists.lisp" + "${generated}/hash-tables.lisp" + "${src}/api.lisp" + "${generated}/methods.lisp" + "${src}/test-functions.lisp" + "${src}/derived.lisp" + "${src}/alias.lisp" + ]; +} diff --git a/third_party/lisp/cl-who.nix b/third_party/lisp/cl-who.nix new file mode 100644 index 000000000000..601b09f118db --- /dev/null +++ b/third_party/lisp/cl-who.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-who; +in depot.nix.buildLisp.library { + name = "cl-who"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "who.lisp" + ]; +} diff --git a/third_party/lisp/cl-yacc.nix b/third_party/lisp/cl-yacc.nix new file mode 100644 index 000000000000..b40d5d0601b2 --- /dev/null +++ b/third_party/lisp/cl-yacc.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "jech"; + repo = "cl-yacc"; + rev = "1334f5469251ffb3f8738a682dc8ee646cb26635"; + sha256 = "16946pzf8vvadnyfayvj8rbh4zjzw90h0azz2qk1mxrvhh5wklib"; + }; +in +depot.nix.buildLisp.library { + name = "cl-yacc"; + + srcs = map (f: src + ("/" + f)) [ + "yacc.lisp" + ]; +} diff --git a/third_party/lisp/closer-mop.nix b/third_party/lisp/closer-mop.nix new file mode 100644 index 000000000000..145b9cfd4325 --- /dev/null +++ b/third_party/lisp/closer-mop.nix @@ -0,0 +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, pkgs, ... }: + +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" + { + sbcl = "${src}/closer-sbcl.lisp"; + ecl = "${src}/closer-ecl.lisp"; + ccl = "${src}/closer-clozure.lisp"; + } + ]; +} diff --git a/third_party/lisp/closure-common.nix b/third_party/lisp/closure-common.nix new file mode 100644 index 000000000000..7f7f79f8551b --- /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 000000000000..1886ea2ec9a2 --- /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 000000000000..a9ffd8085e89 --- /dev/null +++ b/third_party/lisp/closure-html/dtds-from-store.patch @@ -0,0 +1,16 @@ +diff --git a/src/parse/html-parser.lisp b/src/parse/html-parser.lisp +index 4e45b81..5025a26 100644 +--- a/src/parse/html-parser.lisp ++++ b/src/parse/html-parser.lisp +@@ -36,10 +36,7 @@ + (make-pathname + :name nil + :type nil +- :defaults (merge-pathnames +- "resources/" +- (asdf:component-relative-pathname +- (asdf:find-system :closure-html)))))) ++ :defaults "@out@/resources/"))) + (loop + :for (name . filename) + :in '(("-//W3O//DTD W3 HTML 3.0//EN" . "dtd/HTML-3.0") diff --git a/third_party/lisp/closure-html/no-double-defun.patch b/third_party/lisp/closure-html/no-double-defun.patch new file mode 100644 index 000000000000..ce7fb33abff1 --- /dev/null +++ b/third_party/lisp/closure-html/no-double-defun.patch @@ -0,0 +1,78 @@ +diff --git a/src/parse/sgml-dtd.lisp b/src/parse/sgml-dtd.lisp +index de774c0..dbee852 100644 +--- a/src/parse/sgml-dtd.lisp ++++ b/src/parse/sgml-dtd.lisp +@@ -624,73 +624,6 @@ + (return)))) + classes)) + +-;;;; ---------------------------------------------------------------------------------------------------- +-;;;; Compiled DTDs +-;;;; +- +-;; Since parsing and 'compiling' DTDs is slow, I'll provide for a way +-;; to (un)dump compiled DTD to stream. +- +-(defun dump-dtd (dtd sink) +- (let ((*print-pretty* nil) +- (*print-readably* t) +- (*print-circle* t)) +- (princ "#." sink) +- (prin1 +- `(MAKE-DTD :NAME ',(dtd-name dtd) +- :ELEMENTS (LET ((R (MAKE-HASH-TABLE :TEST #'EQ))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-elements dtd)) +- q)) +- R) +- :ENTITIES ',(dtd-entities dtd) +- :RESOLVE-INFO (LET ((R (MAKE-HASH-TABLE :TEST #'EQUAL))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-resolve-info dtd)) +- q)) +- R) +- ;; XXX surclusion-cache fehlt +- ) +- sink))) +- +-;;XXX +-(defun save-html-dtd () +- (with-open-file (sink "html-dtd.lisp" :direction :output :if-exists :new-version) +- (print `(in-package :sgml) sink) +- (let ((*package* (find-package :sgml))) +- (princ "(SETQ " sink) +- (prin1 'cl-user::*html-dtd* sink) +- (princ " '" sink) +- (dump-dtd cl-user::*html-dtd* sink) +- (princ ")" sink)))) +- +-;;; -------------------------------------------------------------------------------- +-;;; dumping DTDs +- +- +-(defun dump-dtd (dtd filename) +- (let ((*foo* dtd)) +- (declare (special *foo*)) +- (with-open-file (sink (merge-pathnames filename "*.lisp") +- :direction :output +- :if-exists :new-version) +- (format sink "(in-package :sgml)(locally (declare (special *foo*))(setq *foo* '#.*foo*))")) +- (compile-file (merge-pathnames filename "*.lisp")))) +- +-(defun undump-dtd (filename) +- (let (*foo*) +- (declare (special *foo*)) +- (load (compile-file-pathname (merge-pathnames filename "*.lisp")) +- :verbose nil +- :print nil) +- *foo*)) +- + (defmethod make-load-form ((self dtd) &optional env) + (declare (ignore env)) + `(make-dtd :name ',(dtd-name self) diff --git a/third_party/lisp/defclass-std.nix b/third_party/lisp/defclass-std.nix new file mode 100644 index 000000000000..c31ddb3c5b74 --- /dev/null +++ b/third_party/lisp/defclass-std.nix @@ -0,0 +1,16 @@ +# A shortcut macro to write DEFCLASS forms quickly +# Seems to be unmaintained (since early 2021) +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.defclass-std; +in depot.nix.buildLisp.library { + name = "defclass-std"; + deps = with depot.third_party.lisp; [ + alexandria + anaphora + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "defclass-std.lisp" + ]; +} diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix new file mode 100644 index 000000000000..607f438d7e72 --- /dev/null +++ b/third_party/lisp/drakma.nix @@ -0,0 +1,34 @@ +# Drakma is an HTTP client for Common Lisp. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.drakma; +in depot.nix.buildLisp.library { + name = "drakma"; + deps = with depot.third_party.lisp; [ + chipz + chunga + cl-base64 + cl-plus-ssl + cl-ppcre + flexi-streams + puri + usocket + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "drakma.asd" # Required because the system definition is used + "packages.lisp" + "specials.lisp" + "conditions.lisp" + "util.lisp" + "read.lisp" + "cookies.lisp" + "encoding.lisp" + "request.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/easy-routes.nix b/third_party/lisp/easy-routes.nix new file mode 100644 index 000000000000..5caf8261fa1c --- /dev/null +++ b/third_party/lisp/easy-routes.nix @@ -0,0 +1,30 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "mmontone"; + repo = "easy-routes"; + rev = "dab613ff419a655036a00beecee026ab6e0ba430"; + sha256 = "06lnipwc6mmg0v5gybcnr7wn5xmn5xfd1gs19vbima777245bfka"; + }; + +in +depot.nix.buildLisp.library { + name = "easy-routes"; + deps = with depot.third_party.lisp; [ + hunchentoot + routes + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "util.lisp" + "easy-routes.lisp" + "routes-map-printer.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/fiveam.nix b/third_party/lisp/fiveam.nix new file mode 100644 index 000000000000..500e980a819a --- /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/flexi-streams.nix b/third_party/lisp/flexi-streams.nix new file mode 100644 index 000000000000..a6a06d4ad057 --- /dev/null +++ b/third_party/lisp/flexi-streams.nix @@ -0,0 +1,33 @@ +# Flexible bivalent streams for Common Lisp +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.flexi-streams; +in depot.nix.buildLisp.library { + name = "flexi-streams"; + deps = [ depot.third_party.lisp.trivial-gray-streams ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "mapping.lisp" + "ascii.lisp" + "koi8-r.lisp" + "mac.lisp" + "iso-8859.lisp" + "enc-cn-tbl.lisp" + "code-pages.lisp" + "specials.lisp" + "util.lisp" + "conditions.lisp" + "external-format.lisp" + "length.lisp" + "encode.lisp" + "decode.lisp" + "in-memory.lisp" + "stream.lisp" + "output.lisp" + "input.lisp" + "io.lisp" + "strings.lisp" + ]; +} + diff --git a/third_party/lisp/global-vars.nix b/third_party/lisp/global-vars.nix new file mode 100644 index 000000000000..a3d27a09b6a0 --- /dev/null +++ b/third_party/lisp/global-vars.nix @@ -0,0 +1,7 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.global-vars; +in depot.nix.buildLisp.library { + name = "global-vars"; + srcs = [ "${src}/global-vars.lisp" ]; +} diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix new file mode 100644 index 000000000000..e2480cd349f1 --- /dev/null +++ b/third_party/lisp/hunchentoot.nix @@ -0,0 +1,62 @@ +# Hunchentoot is a web framework for Common Lisp. +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.hunchentoot; + + url-rewrite = depot.nix.buildLisp.library { + name = "url-rewrite"; + + srcs = map (f: src + ("/url-rewrite/" + f)) [ + "packages.lisp" + "specials.lisp" + "primitives.lisp" + "util.lisp" + "url-rewrite.lisp" + ]; + }; +in +depot.nix.buildLisp.library { + name = "hunchentoot"; + + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + chunga + cl-base64 + cl-fad + rfc2388 + cl-plus-ssl + cl-ppcre + flexi-streams + md5 + trivial-backtrace + usocket + url-rewrite + ]; + + srcs = map (f: src + ("/" + f)) [ + "hunchentoot.asd" + "packages.lisp" + "compat.lisp" + "specials.lisp" + "conditions.lisp" + "mime-types.lisp" + "util.lisp" + "log.lisp" + "cookie.lisp" + "reply.lisp" + "request.lisp" + "session.lisp" + "misc.lisp" + "headers.lisp" + "set-timeouts.lisp" + "taskmaster.lisp" + "acceptor.lisp" + "easy-handlers.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/ironclad.nix b/third_party/lisp/ironclad.nix new file mode 100644 index 000000000000..324c5da265d8 --- /dev/null +++ b/third_party/lisp/ironclad.nix @@ -0,0 +1,163 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) runCommand; + inherit (depot.nix.buildLisp) bundled; + 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") + { sbcl = bundled "sb-rotate-byte"; } + { sbcl = bundled "sb-posix"; } + alexandria + bordeaux-threads + nibbles + ]; + + 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"; } + + { ecl = getSrc "opt/ecl/c-functions.lisp"; } + + { ccl = getSrc "opt/ccl/x86oid-vm.lisp"; } + ] ++ map getSrc [ + "common.lisp" + + "ciphers/cipher.lisp" + "ciphers/padding.lisp" + "ciphers/make-cipher.lisp" + "ciphers/modes.lisp" + + # subsystem def ironclad/ciphers + "ciphers/aes.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/kalyna.lisp" + "ciphers/kuznyechik.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" + "ciphers/sosemanuk.lisp" + "ciphers/square.lisp" + "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" + "digests/crc24.lisp" + "digests/crc32.lisp" + "digests/groestl.lisp" + "digests/jh.lisp" + "digests/kupyna.lisp" + "digests/md2.lisp" + "digests/md4.lisp" + "digests/md5.lisp" + "digests/md5-lispworks-int32.lisp" + "digests/ripemd-128.lisp" + "digests/ripemd-160.lisp" + "digests/sha1.lisp" + "digests/sha256.lisp" + "digests/sha3.lisp" + "digests/sha512.lisp" + "digests/skein.lisp" + "digests/sm3.lisp" + "digests/streebog.lisp" + "digests/tiger.lisp" + "digests/tree-hash.lisp" + "digests/whirlpool.lisp" + + "macs/mac.lisp" + # subsystem def ironclad/macs + "macs/blake2-mac.lisp" + "macs/blake2s-mac.lisp" + "macs/cmac.lisp" + "macs/hmac.lisp" + "macs/gmac.lisp" + "macs/poly1305.lisp" + "macs/siphash.lisp" + "macs/skein-mac.lisp" + + "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/ed25519.lisp" + "public-key/ed448.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 new file mode 100644 index 000000000000..b7d60265ac37 --- /dev/null +++ b/third_party/lisp/iterate.nix @@ -0,0 +1,12 @@ +# iterate is an iteration construct for Common Lisp, similar to the +# LOOP macro. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.iterate; +in depot.nix.buildLisp.library { + name = "iterate"; + srcs = [ + "${src}/package.lisp" + "${src}/iterate.lisp" + ]; +} diff --git a/third_party/lisp/lass.nix b/third_party/lisp/lass.nix new file mode 100644 index 000000000000..00f66c1fe314 --- /dev/null +++ b/third_party/lisp/lass.nix @@ -0,0 +1,35 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "Shinmera"; + repo = "LASS"; + rev = "f51b9e941ee0a2a1f76ba814dcef22f9fb5f69bf"; + sha256 = "11mxzyx34ynsfsrs8pgrarqi9s442vkpmh7kdpzvarhj7i97g8yx"; + }; + +in +depot.nix.buildLisp.library { + name = "lass"; + + deps = with depot.third_party.lisp; [ + trivial-indent + trivial-mimes + physical-quantities + parse-float + cl-base64 + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "readable-list.lisp" + "compiler.lisp" + "property-funcs.lisp" + "writer.lisp" + "lass.lisp" + "special.lisp" + "units.lisp" + "asdf.lisp" + ]; +} diff --git a/third_party/lisp/let-plus.nix b/third_party/lisp/let-plus.nix new file mode 100644 index 000000000000..bd7f31dfa0de --- /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 new file mode 100644 index 000000000000..296112cc9e9a --- /dev/null +++ b/third_party/lisp/lisp-binary.nix @@ -0,0 +1,33 @@ +# A library to easily read and write complex binary formats. +{ depot, pkgs, ... }: + +let + src = pkgs.srcOnly pkgs.lispPackages.lisp-binary; +in +depot.nix.buildLisp.library { + name = "lisp-binary"; + + deps = with depot.third_party.lisp; [ + alexandria + cffi + closer-mop + flexi-streams + moptilities + quasiquote_2 + ]; + + srcs = map (f: src + ("/" + f)) [ + "utils.lisp" + "integer.lisp" + "float.lisp" + "simple-bit-stream.lisp" + "reverse-stream.lisp" + "binary-1.lisp" + "binary-2.lisp" + "types.lisp" + ]; + + brokenOn = [ + "ecl" # TODO(sterni): disable conditionally cffi for ECL + ]; +} diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix new file mode 100644 index 000000000000..1358408d387c --- /dev/null +++ b/third_party/lisp/local-time.nix @@ -0,0 +1,22 @@ +# Library for manipulating dates & times +{ depot, pkgs, ... }: + +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 + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + ]; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/local-time.lisp" + ]; +} diff --git a/third_party/lisp/marshal.nix b/third_party/lisp/marshal.nix new file mode 100644 index 000000000000..73a1664a0162 --- /dev/null +++ b/third_party/lisp/marshal.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.marshal; +in depot.nix.buildLisp.library { + name = "marshal"; + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "serialization-format.lisp" + "coding-idiom.lisp" + "marshal.lisp" + "unmarshal.lisp" + ]; +} diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix new file mode 100644 index 000000000000..8c3e255f166b --- /dev/null +++ b/third_party/lisp/md5.nix @@ -0,0 +1,16 @@ +# MD5 hash implementation +{ depot, pkgs, ... }: + +with depot.nix; + +let src = with pkgs; srcOnly lispPackages.md5; +in buildLisp.library { + name = "md5"; + deps = [ + { + sbcl = buildLisp.bundled "sb-rotate-byte"; + default = depot.third_party.lisp.flexi-streams; + } + ]; + srcs = [ (src + "/md5.lisp") ]; +} diff --git a/third_party/lisp/metabang-bind.nix b/third_party/lisp/metabang-bind.nix new file mode 100644 index 000000000000..fc046d08951a --- /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 000000000000..5051f60d6b86 --- /dev/null +++ b/third_party/lisp/mime4cl/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS new file mode 100644 index 000000000000..2e9580706346 --- /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 000000000000..2704d481ed3c --- /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 000000000000..42688a595b26 --- /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 000000000000..99b23c91aa69 --- /dev/null +++ b/third_party/lisp/mime4cl/default.nix @@ -0,0 +1,50 @@ +# 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 + ]; + + 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 000000000000..2e282c237822 --- /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 000000000000..7951b44f4d0f --- /dev/null +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -0,0 +1,368 @@ +;;; 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) + (: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 + + #:unix-file-stat + #:unix-stat + #: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))) + +(defstruct (unix-file-stat (:conc-name stat-)) + device + inode + links + atime + mtime + ctime + size + blksize + blocks + uid + gid + mode) + +(defun unix-stat (pathname) + ;; this could be different depending on the unix systems + (multiple-value-bind (ok? device inode mode links uid gid rdev + size atime mtime ctime + blksize blocks) + (#+cmu unix:unix-lstat + #+sbcl sb-unix:unix-lstat + ;; TODO(sterni): ECL, CCL + (if (stringp pathname) + pathname + (native-namestring pathname))) + (declare (ignore rdev)) + (when ok? + (make-unix-file-stat :device device + :inode inode + :links links + :atime atime + :mtime mtime + :ctime ctime + :size size + :blksize blksize + :blocks blocks + :uid uid + :gid gid + :mode mode)))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + (stat-size (unix-stat pathname))) + +;; 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 000000000000..3cdac4b26b6f --- /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 000000000000..f3b429eafbf7 --- /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 000000000000..6528f115d47a --- /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 000000000000..94b9e6b39053 --- /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 000000000000..71a32d84e461 --- /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 000000000000..a3653985c40e --- /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 000000000000..6b22b3f6a287 --- /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 000000000000..dbd1dd996dcc --- /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 000000000000..965680448fe4 --- /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 000000000000..3f3aa5c56cd3 --- /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 000000000000..662a9fab341e --- /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 000000000000..554f35844b46 --- /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 new file mode 100644 index 000000000000..d38fbcb9469a --- /dev/null +++ b/third_party/lisp/moptilities.nix @@ -0,0 +1,13 @@ +# Compatibility layer for minor MOP implementation differences +{ depot, pkgs, ... }: + +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 new file mode 100644 index 000000000000..b71f439c939a --- /dev/null +++ b/third_party/lisp/nibbles.nix @@ -0,0 +1,26 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.nibbles; +in +depot.nix.buildLisp.library { + name = "nibbles"; + + deps = with depot.third_party.lisp; [ + (bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "types.lisp" + "macro-utils.lisp" + "vectors.lisp" + "streams.lisp" + ] ++ [ + { sbcl = "${src}/sbcl-opt/fndb.lisp"; } + { sbcl = "${src}/sbcl-opt/nib-tran.lisp"; } + { sbcl = "${src}/sbcl-opt/x86-vm.lisp"; } + { sbcl = "${src}/sbcl-opt/x86-64-vm.lisp"; } + ]; +} diff --git a/third_party/lisp/npg/.project b/third_party/lisp/npg/.project new file mode 100644 index 000000000000..82a8fe48bbfb --- /dev/null +++ b/third_party/lisp/npg/.project @@ -0,0 +1 @@ +NPG a Naive Parser Generator diff --git a/third_party/lisp/npg/.skip-subtree b/third_party/lisp/npg/.skip-subtree new file mode 100644 index 000000000000..5051f60d6b86 --- /dev/null +++ b/third_party/lisp/npg/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING new file mode 100644 index 000000000000..223ede7de3ec --- /dev/null +++ b/third_party/lisp/npg/COPYING @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/third_party/lisp/npg/OWNERS b/third_party/lisp/npg/OWNERS new file mode 100644 index 000000000000..2e9580706346 --- /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 000000000000..a1661e744a37 --- /dev/null +++ b/third_party/lisp/npg/README @@ -0,0 +1,48 @@ + + NPG a Naive Parser Generator + for Common Lisp + + Copyright (C) 2003-2006, 2010 by Walter C. Pelissero + Copyright (C) 2021 by the TVL Authors + +Vendored into depot as it is a dependency of mime4cl and upstream has +become inactive. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#npg +Vendored Tarball: http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz + +This library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation; either version 2.1 of the +License, or (at your option) any later version. This library is +distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. You should have received a copy of the GNU +Lesser General Public License along with this library; if not, write +to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +Boston, MA 02111-1307 USA + + +This library generates on the fly (no external representation of the +parser is produced) a recursive descent parser based on the grammar +rules you have fed it with. The parser object can then be used to +scan tokenised input. Although a facility to produce a lexical +analiser is not provided, to write such a library is fairly easy for +most languages. NPG parsers require your lexer to adhere to a certain +protocol to be able to communicate with them. Examples are provided +that explain these requirements. + +While quite possibly not producing the fastest parsers in town, it's +fairly simple and hopefully easy to debug. It accepts a lispy EBNF +grammar description of arbitrary complexity with the exception of +mutually left recursive rules (watch out, they produce undetected +infinite recursion) and produces a backtracking recursive descent +parser. Immediate left recursive rules are properly simplified, +though. + +Multiple concurrent parsers are supported. + +To compile, an ASDF and nix file are provided. + +See the examples directory for clues on how to use it. diff --git a/third_party/lisp/npg/default.nix b/third_party/lisp/npg/default.nix new file mode 100644 index 000000000000..af7ec53eaf93 --- /dev/null +++ b/third_party/lisp/npg/default.nix @@ -0,0 +1,14 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "npg"; + + srcs = [ + ./src/package.lisp + ./src/common.lisp + ./src/define.lisp + ./src/parser.lisp + ]; +} diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp new file mode 100644 index 000000000000..a45ac614f716 --- /dev/null +++ b/third_party/lisp/npg/examples/python.lisp @@ -0,0 +1,336 @@ +;;; python.lisp --- sample grammar definition for the Python language + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is far from being a complete Python grammar. Actually I +;;; haven't even read a Python book before starting to write this +;;; stuff, so the code below comes mostly from wild guessing while +;;; reading a Python source file. +;;; +;;; It's a design decision to avoid writing any transformation in this +;;; module; only tagging is done at this level. This improves the +;;; separation between parsing and transformation, making the grammar +;;; reusable for other purposes. + + +#+cmu (ext:file-comment "$Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $") + +(in-package :grammar) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "~&creating Python grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () + +(defrule program + := comment-string? statement+) + +(defrule comment-string + := string eol + :reduce string) + +;;; BOB = Beginning Of Block, EOB = End Of Block. It's lexical +;;; analyzer's task to find out where a statement or block starts/ends. + +(defrule suite + := statement-list eol + :reduce statement-list + := statement-block) + +(defrule commentable-suite + := statement-list eol + :reduce statement-list + := commented-statement-block) + +(defrule statement-block + := bob statement+ eob + :reduce $2) + +(defrule commented-statement-block + := bob comment-string? statement* eob + :reduce (cons comment-string statement)) + +(defrule statement-list + := (+ simple-statement ";") + :reduce (if (cdr $1) + (cons :statement-list $1) + (car $1))) + +(defrule statement + := statement-list eol + :reduce statement-list + := compound-statement) + +(defrule simple-statement + := import-statement + := raise-statement + := assignment + := function-call + := return-statement + := assert-statement + := pass-statement + := break-statement + := continue-statement) + +(defrule compound-statement + := class-definition + := method-definition + := try-statement + := if-statement + := while-statement + := for-statement) + +(defrule import-statement + := "import" (+ package-name ",") + :tag :import + := "from" package-name "import" (+ symbol-name ",") + :tag :import-from) + +(defrule package-name := identifier) + +(defrule symbol-name + := identifier + := "*") + +(defrule try-statement + := "try" ":" suite try-except-part* try-finally-part? + :tag :try) + +(defrule try-except-part + := "except" exception-subject? ":" suite) + +(defrule try-finally-part + := "finally" ":" suite) + +(defrule exception-subject + := exception-name exception-variable?) + +(defrule exception-variable + := "," identifier) + +(defrule exception-name := class-name) + +(defrule class-name := identifier) + +(defrule raise-statement + := "raise" + :tag :raise-same + := "raise" exception-name + :tag :raise + := "raise" exception-name "," expression + :tag :raise + := "raise" exception-name "(" expression ")" + :tag :raise) + +(defrule assignment + := (+ variable-with-optional-subscript ",") "=" more-assignment + :tag :set) + +(defrule more-assignment + := expression + := assignment) + +(defrule variable-with-optional-subscript + := variable-name subscript + :tag :subscript + := variable-name) + +(defrule variable-name + := (+ identifier ".") + :tag :varef) + +(defrule expression + := expression "or" expression1 + :tag :or + := expression1) + +(defrule expression1 + := expression1 "and" expression2 + :tag :and + := expression2) + +(defrule expression2 + := expression2 "==" expression3 + :tag :equal + := expression2 ">=" expression3 + :tag :more-equal + := expression2 "<=" expression3 + :tag :less-equal + := expression2 "!=" expression3 + :tag :not-equal + := expression2 ">" expression3 + :tag :more + := expression2 "<" expression3 + :tag :less + := expression2 "is" expression3 + :tag :equal + := expression2 "is" "not" expression3 + :tag :not-equal + := expression3) + +(defrule expression3 + := expression3 "+" expression4 + :tag :plus + := expression3 "-" expression4 + :tag :minus + := expression3 "|" expression4 + :tag :bit-or + := expression4) + +;; high priority expression +(defrule expression4 + := expression4 "*" expression5 + :tag :mult + := expression4 "/" expression5 + :tag :div + := expression4 "%" expression5 + :tag :modulo + := expression4 "&" expression5 + :tag :bit-and + := expression4 "in" expression5 + :tag :in + := expression5) + +(defrule expression5 + := "~" expression5 + :tag :bit-not + := "not" expression5 + :tag :not + := "(" expression ")" + := expression6) + +(defrule expression6 + := simple-expression subscript + :tag :subscript + := simple-expression) + +(defrule simple-expression + := function-call + := variable-name + := constant + := string-conversion + := list-constructor) + +(defrule subscript + := "[" expression "]" + := "[" expression ":" expression "]" + := "[" expression ":" "]" + :reduce (list expression nil) + := "[" ":" expression "]" + :reduce (list nil expression)) + +(defrule string-conversion + := "`" expression "`" + :tag :to-string) + +(defrule constant + := number + := string + := lambda-expression) + +(defrule number + := float + := integer) + +(defrule list-constructor + := "[" (* expression ",") "]" + :tag :make-list) + +(defrule class-definition + := "class" class-name superclasses? ":" commentable-suite + :tag :defclass) + +(defrule superclasses + := "(" class-name+ ")") + +(defrule method-definition + := "def" method-name "(" method-arguments ")" ":" commentable-suite + :tag :defmethod) + +(defrule method-arguments + := (* method-argument ",")) + +(defrule method-argument + := identifier argument-default?) + +(defrule argument-default + := "=" expression) + +(defrule method-name := identifier) + +(defrule if-statement + := "if" expression ":" suite elif-part* else-part? + :tag :if) + +(defrule else-part + := "else" ":" suite) + +(defrule elif-part + := "elif" expression ":" suite) + +(defrule lambda-expression + := "lambda" method-arguments ":" expression + :tag :lambda) + +(defrule function-call + := (+ identifier ".") "(" (* expression ",") ")" + :tag :funcall) + +(defrule for-statement + := "for" identifier "in" expression ":" suite + :tag :do-list + := "for" identifier "in" "range" "(" expression "," expression ")" ":" suite + :tag :do-range) + +(defrule while-statement + := "while" expression ":" suite + :tag :while) + +(defrule return-statement + := "return" expression? + :tag :return) + +(defrule assert-statement + := "assert" expression "," string + :tag :assert) + +(defrule pass-statement + := "pass" + :tag :pass) + +(defrule break-statement + := "break" + :tag :break) + +(defrule continue-statement + := "continue" + :tag :continue) + +) ; end of POPULATE-GRAMMAR diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp new file mode 100644 index 000000000000..9ebd45a169ce --- /dev/null +++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp @@ -0,0 +1,1901 @@ +;;; vs-cobol-ii.lisp --- sample grammar for VS-Cobol II + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; A fairly incomplete VS-Cobol II grammar fro NPG. It's probably +;;; not very accurate either. + +#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $") + +(in-package :grammar) + +(defun make-keyword (string) + "Create a keyword from STRING." + (intern (string-upcase string) :keyword)) + +(defun flatten-list (list) + "Remove one depth level in LIST." + (mapcan #'identity list)) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "creating Cobol grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () +;;; +;;; Hereafter PP means Partial Program +;;; + +#+nil +(defrule pp--declarations + := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest) + +;;; We need to split the parsing of the declarations from the rest +;;; because the declarations may change the lexical rules (ie decimal +;;; point) + +(defrule pp--declarations + := identification-division environment-division? data-division-head-or-procedure-division-head :rest) + +(defrule data-division-head-or-procedure-division-head + := data-division-head + :reduce :data-division + := procedure-division-head + :reduce (list :procedure-division $1)) + +(defrule pp--data-division + := data-division-content procedure-division-head :rest) + +(defrule pp--sentence + := sentence :rest + := :eof) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The real grammar +;;; + +(defrule cobol-source-program + := identification-division environment-division? data-division procedure-division end-program?) + +(defrule identification-division + := identification "DIVISION" "." program-id-cobol-source-program identification-division-content + :reduce program-id-cobol-source-program) + +(defrule priority-number + := integer) + +(defrule level-number + := integer) + +(defrule to-id-or-lit + := "TO" id-or-lit) + +(defrule inspect-by-argument + := variable-identifier + := string + := figurative-constant-simple) + +(defrule figurative-constant-simple + := "ZERO" + :reduce :zero + := "ZEROS" + :reduce :zero + := "ZEROES" + :reduce :zero + := "SPACE" + :reduce :space + := "SPACES" + :reduce :space + := "HIGH-VALUE" + :reduce :high + := "HIGH-VALUES" + :reduce :high + := "LOW-VALUE" + :reduce :low + := "LOW-VALUES" + :reduce :low + := "QUOTE" + :reduce :quote + := "QUOTES" + :reduce :quote + := "NULL" + :reduce :null + := "NULLS" + :reduce :null) + +(defrule write-exceptions + := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?) + +(defrule set-statement-phrase + := variable-identifier+ set-oper set-src) + +(defrule set-src + := variable-identifier + := literal + := "TRUE" + := "ON" + := "OFF") + +(defrule set-oper + := "TO" + :reduce :to + := "UP" "BY" + :reduce :up + := "DOWN" "BY" + :reduce :down) + +(defrule fce-phrase + := reserve-clause + := fce-organization + := fce-access-mode + := record-key-clause + := password-clause + := alternate-record-key-clause + := file-status-clause + := padding-character-clause + := record-delimiter-clause) + +(defrule fce-organization + := organization-is? alt-indexed-relative-sequential + :reduce (list :organization (make-keyword alt-indexed-relative-sequential))) + +(defrule fce-access-mode + := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause? + :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic))) + +(defrule alt-indexed-relative-sequential + := "INDEXED" + := "RELATIVE" + := "SEQUENTIAL") + +(defrule is-not + := "IS"? "NOT"?) + +(defrule all-procedures + := "ALL" "PROCEDURES") + +(defrule next-sentence + := "NEXT" "SENTENCE") + +(defrule no-rewind + := "NO" "REWIND") + +(defrule for-removal + := "FOR"? "REMOVAL") + +(defrule values + := "VALUE" + := "VALUES") + +(defrule records + := "RECORD" + := "RECORDS") + +(defrule end-program + := "END" "PROGRAM" program-name ".") + +(defrule environment-division + := "ENVIRONMENT" "DIVISION" "." environment-division-content) + +(defrule data-division-head + := "DATA" "DIVISION" ".") + +(defrule data-division + := data-division-head data-division-content + :reduce data-division-content) + +(defrule identification + := "IDENTIFICATION" + := "ID") + +(defrule identification-division-content + := identification-division-phrase*) + +(defrule author + := "AUTHOR" ".") + +(defrule installation + := "INSTALLATION" ".") + +(defrule date-written + := "DATE-WRITTEN" ".") + +(defrule date-compiled + := "DATE-COMPILED" ".") + +(defrule security + := "SECURITY" ".") + +(defrule remarks + := "REMARKS" ".") + +(defrule identification-division-phrase + := author + := installation + := date-written + := date-compiled + := security + := remarks) + +(defrule program-id-cobol-source-program + := "PROGRAM-ID" "."? program-name initial-program? "." + :reduce program-name) + +(defrule initial-program + := "IS"? "INITIAL" "PROGRAM"?) + +(defrule environment-division-content + := configuration-section? input-output-section?) + +(defrule input-output-section + := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph? + :reduce file-control-paragraph) + +(defrule file-control-paragraph + := "FILE-CONTROL" "." file-control-entry*) + +(defrule file-control-entry + := select-clause assign-clause fce-phrase* "." + :reduce (append select-clause + assign-clause + (flatten-list fce-phrase))) + +(defrule organization-is + := "ORGANIZATION" "IS"?) + +(defrule alt-sequential-random-dynamic + := "SEQUENTIAL" + := "RANDOM" + := "DYNAMIC") + +(defrule select-clause + := "SELECT" "OPTIONAL"? file-name + :reduce (list file-name :optional (and $2 t))) + +(defrule assign-clause + := "ASSIGN" "TO"? alt-assignment-name-literal+ + :reduce (list :assign alt-assignment-name-literal)) + +(defrule alt-assignment-name-literal + := assignment-name + := literal) + +(defrule reserve-clause + := "RESERVE" integer areas?) + +(defrule areas + := "AREA" + := "AREAS") + +(defrule padding-character-clause + := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal) + +(defrule record-delimiter-clause + := "RECORD" "DELIMITER" "IS"? record-delimiter-name) + +(defrule record-delimiter-name + := "STANDARD-1" + := assignment-name) + +(defrule password-clause + := "PASSWORD" "IS"? data-name) + +(defrule file-status-clause + := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name? + :reduce (list :file-status qualified-data-name)) + +(defrule relative-key-clause + := "RELATIVE" "KEY"? "IS"? qualified-data-name + :reduce (list :relative-key qualified-data-name)) + +(defrule record-key-clause + := "RECORD" "KEY"? "IS"? qualified-data-name + :reduce (list :key qualified-data-name)) + +(defrule alternate-record-key-clause + := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates? + :reduce (list :alternate-key qualified-data-name with-duplicates)) + +(defrule with-duplicates + := "WITH"? "DUPLICATES") + +(defrule i-o-control-paragraph + := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?) + +(defrule i-o-sam + := qsam-or-sam-or-vsam-i-o-control-entries+ ".") + +(defrule i-o-sort-merge + := sort-merge-i-o-control-entries ".") + +(defrule qsam-or-sam-or-vsam-i-o-control-entries + := qsam-or-sam-or-vsam-i-o-control-entries-1 + := qsam-or-sam-or-vsam-i-o-control-entries-2 + := qsam-or-sam-or-vsam-i-o-control-entries-3 + := qsam-or-sam-or-vsam-i-o-control-entries-4) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-1 + := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name) + +(defrule every-phrase-1 + := integer "RECORDS") + +(defrule every-phrase-2 + := "END" "OF"? alt-reel-unit) + +(defrule every-phrase + := every-phrase-1 + := every-phrase-2) + +(defrule alt-assignment-name-file-name + := assignment-name + := file-name) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-2 + := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-3 + := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+) + +(defrule position + := "POSITION" integer) + +(defrule file-name-position + := file-name position?) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-4 + := "APPLY" "WRITE-ONLY" "ON"? file-name+) + +(defrule sort-merge-i-o-control-entries + := rerun-on? same-area+) + +(defrule rerun-on + := "RERUN" "ON" assignment-name) + +(defrule record-sort + := "RECORD" + := "SORT" + := "SORT-MERGE") + +(defrule same-area + := "SAME" record-sort "AREA"? "FOR"? file-name file-name+) + +(defrule configuration-section + := "CONFIGURATION" "SECTION" "." configuration-section-paragraph* + :reduce (flatten-list configuration-section-paragraph)) + +(defrule configuration-section-paragraph + := source-computer-paragraph + := object-computer-paragraph + := special-names-paragraph) + +(defrule source-computer-paragraph + := "SOURCE-COMPUTER" "." source-computer-name + :reduce (list :source-computer source-computer-name)) + +(defrule with-debugging-mode + := "WITH"? "DEBUGGING" "MODE") + +(defrule source-computer-name + := computer-name with-debugging-mode? "." + :reduce computer-name) + +(defrule object-computer-paragraph + := "OBJECT-COMPUTER" "." object-computer-name + :reduce (list :object-computer object-computer-name)) + +(defrule memory-size-type + := "WORDS" + := "CHARACTERS" + := "MODULES") + +(defrule memory-size + := "MEMORY" "SIZE"? integer memory-size-type) + +(defrule object-computer-name + := computer-name memory-size? object-computer-paragraph-sequence-phrase "." + :reduce computer-name) + +(defrule object-computer-paragraph-sequence-phrase + := program-collating-sequence? segment-limit?) + +(defrule program-collating-sequence + := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule segment-limit + := "SEGMENT-LIMIT" "IS"? priority-number) + +(defrule special-names-paragraph + := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "." + :reduce (flatten-list special-names-paragraph-clause)) + +(defrule is-mnemonic-name + := "IS"? mnemonic-name special-names-paragraph-status-phrase?) + +(defrule special-names-paragraph-phrase-tail + := is-mnemonic-name + := special-names-paragraph-status-phrase) + +(defrule special-names-paragraph-phrase + := environment-name special-names-paragraph-phrase-tail) + +(defrule special-names-paragraph-status-phrase + := special-names-paragraph-status-phrase-1 + := special-names-paragraph-status-phrase-2) + +(defrule special-names-paragraph-status-phrase-1 + := "ON" "STATUS"? "IS"? condition off-status?) + +(defrule off-status + := "OFF" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-status-phrase-2 + := "OFF" "STATUS"? "IS"? condition on-status?) + +(defrule on-status + := "ON" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-clause + ;; := alphabet-clause + ;; := symbolic-characters-clause + := currency-sign-clause + := decimal-point-clause) + +(defrule alphabet-clause + := "ALPHABET" alphabet-name "IS"? alphabet-type) + +(defrule alphabet-type-also + := "ALSO" literal) + +(defrule alphabet-type-alsos + := alphabet-type-also+) + +(defrule alphabet-type-also-through + := through-literal + := alphabet-type-alsos) + +(defrule alphabet-type-other + := literal alphabet-type-also-through?) + +(defrule alphabet-type-others + := alphabet-type-other+) + +(defrule alphabet-type + := "STANDARD-1" + := "STANDARD-2" + := "NATIVE" + := "EBCDIC" + := alphabet-type-others) + +(defrule symbolic-characters-clause + := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?) + +(defrule are + := "ARE" + := "IS") + +(defrule symbolic-character-mapping + := symbolic-character+ are? integer+) + +(defrule in-alphabet-name + := "IN" alphabet-name) + +(defrule currency-sign-clause + := "CURRENCY" "SIGN"? "IS"? literal + :reduce (list :currency-sign literal)) + +(defrule decimal-point-clause + := "DECIMAL-POINT" "IS"? "COMMA" + :reduce (list :decimal-point #\,)) + +(defrule data-division-content + := file-section? working-storage-section? linkage-section?) + +(defrule file-section-entry + := file-and-sort-description-entry data-description-entry+ + :reduce (cons file-and-sort-description-entry data-description-entry)) + +(defrule file-section-head + := "FILE" "SECTION" ".") + +(defrule file-section + := file-section-head file-section-entry* + :reduce $2) + +(defrule working-storage-section-head + := "WORKING-STORAGE" "SECTION" ".") + +(defrule working-storage-section + := working-storage-section-head data-description-entry* + :reduce $2) + +(defrule linkage-section-head + := "LINKAGE" "SECTION" ".") + +(defrule linkage-section + := linkage-section-head data-description-entry* + :reduce $2) + +(defrule file-and-sort-description-entry + := alt-fd-sd file-name file-and-sort-description-entry-clause* "." + :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause)) + +(defrule alt-fd-sd + := "FD" + := "SD") + +(defrule file-and-sort-description-entry-clause + := external-clause + := global-clause + := block-contains-clause + := record-clause + := label-records-clause + := value-of-clause + := data-records-clause + := linage-clause + := recording-mode-clause + := code-set-clause) + +(defrule integer-to + := integer "TO") + +(defrule block-contains-clause + := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?) + +(defrule alt-characters-records + := "CHARACTERS" + := "RECORDS" + := "RECORD") + +(defrule record-clause + := "RECORD" record-clause-tail) + +(defrule depending-on + := "DEPENDING" "ON"? data-name) + +(defrule record-clause-tail-1 + := "CONTAINS"? integer "CHARACTERS"?) + +(defrule record-clause-tail-2 + := "CONTAINS"? integer "TO" integer "CHARACTERS"?) + +(defrule record-clause-tail-3 + := record-varying-phrase depending-on?) + +(defrule record-clause-tail + := record-clause-tail-2 + := record-clause-tail-1 + := record-clause-tail-3) + +(defrule record-varying-phrase + := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?) + +(defrule from-integer + := "FROM"? integer) + +(defrule to-integer + := "TO" integer) + +(defrule label-records-clause + := "LABEL" records-are label-records-clause-tail + :reduce (list :label-record label-records-clause-tail)) + +(defrule data-names + := data-name+) + +(defrule label-records-clause-tail + := "STANDARD" :reduce :standard + := "OMITTED" :reduce :omitted + := data-names) + +(defrule value-of-clause + := "VALUE" "OF" value-of-clause-tail+) + +(defrule alt-qualified-data-name-literal + := qualified-data-name + := literal) + +(defrule value-of-clause-tail + := variable-identifier "IS"? alt-qualified-data-name-literal) + +(defrule data-records-clause + := "DATA" records-are data-name+) + +(defrule records-are + := records are?) + +(defrule linage-clause + := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase) + +(defrule linage-footing-phrase + := footing? lines-top? lines-bottom?) + +(defrule alt-data-name-integer + := data-name + := integer) + +(defrule footing + := "WITH"? "FOOTING" "AT"? alt-data-name-integer) + +(defrule lines-top + := "LINES"? "AT"? "TOP" alt-data-name-integer) + +(defrule lines-bottom + := "LINES"? "AT"? "BOTTOM" alt-data-name-integer) + +(defrule recording-mode-clause + := "RECORDING" "MODE"? "IS"? variable-identifier) + +(defrule code-set-clause + := "CODE-SET" "IS"? alphabet-name) + +(defrule data-description-entry + := level-number alt-data-name-filler? data-description-entry-clause* "." + :reduce (append (list level-number alt-data-name-filler) + (flatten-list data-description-entry-clause))) + +(defrule alt-data-name-filler + := data-name + := "FILLER" + :reduce (list)) + +(defrule data-description-entry-clause + := picture-clause + := redefines-clause + := blank-when-zero-clause + := external-clause + := global-clause + := justified-clause + := occurs-clause + := sign-clause + := synchronized-clause + := usage-clause + := renames-clause + := value-clause) + +(defrule value-clause + := "VALUE" "IS"? literal + :reduce (list :value literal)) + +(defrule redefines-clause + := "REDEFINES" data-name + :reduce `(:redefines ,data-name)) + +(defrule blank-when-zero-clause + := "BLANK" "WHEN"? zeroes + :reduce '(:blank-when-zero t)) + +(defrule zeroes + := "ZERO" + := "ZEROS" + := "ZEROES") + +(defrule external-clause + := "IS"? "EXTERNAL" + :reduce '(:external t)) + +(defrule global-clause + := "IS"? "GLOBAL" + :reduce '(:global t)) + +(defrule justified-clause + := justified "RIGHT"? + :reduce `(:justified ,(if $2 :right :left))) + +(defrule justified + := "JUSTIFIED" + := "JUST") + +(defrule occurs-clause + := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times ,integer) + := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times (,integer ,integer2 ,qualified-data-name))) + +(defrule occurs-clause-key + := alt-ascending-descending "KEY"? "IS"? qualified-data-name+) + +(defrule indexed-by + := "INDEXED" "BY"? index-name+) + +(defrule picture-clause + := picture "IS"? picture-string + :reduce `(:picture ,picture-string)) + +(defrule picture + := "PICTURE" + := "PIC") + +(defrule sign-clause + := sign-is? alt-leading-trailing separate-character? + :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing)) + +(defrule sign-is + := "SIGN" "IS"?) + +(defrule separate-character + := "SEPARATE" "CHARACTER"? + :reduce t) + +(defrule alt-leading-trailing + := "LEADING" + :reduce :leading + := "TRAILING" + :reduce :trailing) + +(defrule synchronized-clause + := synchronized alt-left-right? + :reduce `(:synchronized ,(if alt-left-right + alt-left-right + t))) + +(defrule alt-left-right + := "LEFT" + :reduce :left + := "RIGHT" + :reduce :right) + +(defrule synchronized + := "SYNCHRONIZED" + := "SYNC") + +(defrule usage-clause + := usage-is? usage + :reduce (list :encoding usage)) + +(defrule usage-is + := "USAGE" "IS"?) + +(defrule usage + := "BINARY" + :reduce :binary + := "COMP" + :reduce :comp + := "COMP-1" + :reduce :comp1 + := "COMP-2" + :reduce :comp2 + := "COMP-3" + :reduce :comp3 + := "COMP-4" + :reduce :comp4 + := "COMPUTATIONAL" + :reduce :comp + := "COMPUTATIONAL-1" + :reduce :comp1 + := "COMPUTATIONAL-2" + :reduce :comp2 + := "COMPUTATIONAL-3" + :reduce :comp3 + := "COMPUTATIONAL-4" + :reduce :comp4 + := "DISPLAY" + :reduce :display + := "DISPLAY-1" + :reduce :display1 + := "INDEX" + :reduce :index + := "PACKED-DECIMAL" + :reduce :packed-decimal + := "POINTER" + :reduce :pointer) + +(defrule renames-clause + := "RENAMES" qualified-data-name through-qualified-data-name? + :reduce `(:renames ,qualified-data-name ,through-qualified-data-name)) + +(defrule through-qualified-data-name + := through qualified-data-name + :reduce qualified-data-name) + +(defrule condition-value-clause + := values-are literal-through-literal+) + +(defrule through-literal + := through literal) + +(defrule literal-through-literal + := literal through-literal?) + +(defrule values-are + := values are?) + +(defrule procedure-division-head + := "PROCEDURE" "DIVISION" using-phrase? ".") + +(defrule procedure-division + := procedure-division-head sentence+) + +(defrule using-phrase + := "USING" data-name+) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule declaratives + := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".") + +(defrule declaratives-content + := cobol-identifier "SECTION" "." use-statement "." sentence*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule paragraph-header + := cobol-identifier "SECTION"? + :reduce (list (if $2 :section :label) $1)) + +(defrule sentence + := declaratives + := statement* "." + :reduce $1 + := paragraph-header "." + :reduce $1) + +(defrule statement + := move-statement + := if-statement + := perform-statement + := go-to-statement + := accept-statement + := add-statement + := alter-statement + := call-statement + := cancel-statement + := close-statement + := compute-statement + := continue-statement + := delete-statement + := display-statement + := divide-statement + := entry-statement + := evaluate-statement + := exit-program-statement + := exit-statement + := goback-statement + := initialize-statement + := inspect-statement + := merge-statement + := multiply-statement + := open-statement + := read-statement + := release-statement + := return-statement + := rewrite-statement + := search-statement + := set-statement + := sort-statement + := start-statement + := stop-statement + := string-statement + := subtract-statement + := unstring-statement + := write-statement + := paragraph-header) + +(defrule accept-statement + := "ACCEPT" variable-identifier "FROM" date + := "ACCEPT" variable-identifier "AT" screen-coordinates + :reduce (apply #'list 'accept-at variable-identifier screen-coordinates) + := "ACCEPT" variable-identifier from-environment-name?) + +(defrule from-environment-name + := "FROM" cobol-identifier) + + +(defrule date + := "DATE" + := "DAY" + := "DAY-OF-WEEK" + := "TIME") + +(defrule add-statement + := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?) + +(defrule statement-list + := statement+) + +(defrule alter-statement + := "ALTER" procedure-to-procedure+) + +(defrule proceed-to + := "PROCEED" "TO") + +(defrule procedure-to-procedure + := procedure-name "TO" proceed-to? procedure-name) + +(defrule call-statement + := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"? + :reduce (list 'call id-or-lit (cons 'list using-parameters))) + +(defrule by-reference + := "BY"? "REFERENCE") + +(defrule content-parameter-value + := cobol-identifier + := literal) + +(defrule reference-parameter + := by-reference? variable-identifier) + +(defrule content-parameter + := "BY"? "CONTENT" content-parameter-value+) + +(defrule parameter + := reference-parameter + := content-parameter + := literal) + +(defrule using-parameters + := "USING" parameter+) + +(defrule call-rest-phrase + := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?) + +(defrule on-exception-statement-list + := "ON"? "EXCEPTION" statement-list) + +(defrule not-on-exception-statement-list + := "NOT" "ON"? "EXCEPTION" statement-list) + +(defrule cancel-statement + := "CANCEL" id-or-lit+) + +(defrule close-statement + := "CLOSE" close-statement-file-name+ + :reduce (list 'close close-statement-file-name)) + +(defrule alt-removal-no-rewind + := for-removal + := with-no-rewind) + +(defrule alt-reel-unit + := "REEL" + := "UNIT") + +(defrule alt-no-rewind-lock + := no-rewind + := "LOCK") + +(defrule close-statement-options-1 + := alt-reel-unit alt-removal-no-rewind?) + +(defrule close-statement-options-2 + := "WITH"? alt-no-rewind-lock) + +(defrule close-statement-options + := close-statement-options-1 + := close-statement-options-2) + +(defrule close-statement-file-name + := file-name close-statement-options?) + +(defrule compute-statement + := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"? + :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule equal + := "=" + := "EQUAL") + +(defrule continue-statement + := "CONTINUE") + +(defrule delete-statement + := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"? + :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list)) + +(defrule display-statement + := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing? + :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing)) + := "DISPLAY" id-or-lit "AT" screen-coordinates + :reduce (apply #'list 'display-at id-or-lit screen-coordinates)) + +(defrule screen-coordinates + := integer + :reduce (multiple-value-list (truncate integer 100))) + +(defrule upon-environment-name + := "UPON" cobol-identifier) + +(defrule with-no-advancing + := "WITH"? "NO" "ADVANCING") + +(defrule divide-statement + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?) + +(defrule entry-statement + := "ENTRY" literal using-phrase?) + +(defrule evaluate-statement + := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?) + +(defrule evaluate-condition + := condition + := "TRUE" + := "FALSE") + +(defrule also-phrase + := "ALSO" evaluate-condition) + +(defrule when-phrase-also-phrase + := "ALSO" evaluate-phrase) + +(defrule when-phrase + := "WHEN" evaluate-phrase when-phrase-also-phrase*) + +(defrule when-phrases + := when-phrase+ statement-list) + +(defrule when-other-phrase + := "WHEN" "OTHER" statement-list) + +(defrule evaluate-phrase + := "ANY" + := condition + := "TRUE" + := "FALSE" + := evaluate-phrase-1) + +(defrule evaluate-phrase-1 + := "NOT"? arithmetic-expression through-arithmetic-expression?) + +(defrule through-arithmetic-expression + := through arithmetic-expression) + +(defrule exit-statement + := "EXIT" + :reduce '(exit-paragraph)) + +(defrule exit-program-statement + := "EXIT" "PROGRAM" + :reduce '(exit-program)) + +(defrule goback-statement + := "GOBACK" + :reduce '(go-back)) + +(defrule go-to-statement + := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier + :reduce (list 'goto-depending variable-identifier procedure-name) + := "GO" "TO"? procedure-name + :reduce (list 'goto procedure-name)) + +(defrule if-phrase + := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence + :reduce (list 'if condition + (if (cdr alt-statement-list-next-sentence) + (cons 'progn alt-statement-list-next-sentence) + (car alt-statement-list-next-sentence)) + (if (cdr alt-statement-list-next-sentence2) + (cons 'progn alt-statement-list-next-sentence2) + (car alt-statement-list-next-sentence2))) + := "IF" condition "THEN"? alt-statement-list-next-sentence + :reduce (append (list 'when condition) alt-statement-list-next-sentence)) + +(defrule if-statement + := if-phrase "END-IF"? + :reduce $1) + +(defrule initialize-statement + := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?) + +(defrule initialize-replacing-type + := "ALPHABETIC" + := "ALPHANUMERIC" + := "NUMERIC" + := "ALPHANUMERIC-EDITED" + := "NUMERIC-EDITED" + := "DBCS" + := "EGCS") + +(defrule initialize-replacing-argument + := initialize-replacing-type "DATA"? "BY" id-or-lit) + +(defrule initialize-replacing-phrase + := "REPLACING" initialize-replacing-argument+) + +(defrule inspect-statement + := inspect-statement-1 + := inspect-statement-2 + := inspect-statement-3 + := inspect-statement-4) + +(defrule inspect-statement-1 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+) + +(defrule inspect-statement-2 + := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*) + +(defrule inspect-statement-3 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+) + +(defrule tallying-for-id-or-lit + := id-or-lit before-after-phrase*) + +(defrule alt-all-leading + := "ALL" + := "LEADING") + +(defrule tallying-for-argument-1 + := "CHARACTERS" before-after-phrase*) + +(defrule tallying-for-argument-2 + := alt-all-leading tallying-for-id-or-lit+) + +(defrule tallying-for-argument + := tallying-for-argument-1 + := tallying-for-argument-2) + +(defrule tallying-argument + := variable-identifier "FOR" tallying-for-argument+) + +(defrule inspect-statement-4 + := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+) + +(defrule inspect-replacing-argument + := inspect-by-argument "BY" inspect-by-argument before-after-phrase*) + +(defrule alt-all-leading-first + := "ALL" + := "LEADING" + := "FIRST") + +(defrule inspect-replacing-phrase-1 + := "CHARACTERS" "BY" id-or-lit before-after-phrase*) + +(defrule inspect-replacing-phrase-2 + := alt-all-leading-first inspect-replacing-argument+) + +(defrule inspect-replacing-phrase + := inspect-replacing-phrase-1 + := inspect-replacing-phrase-2) + +(defrule before-after-phrase + := alt-before-after "INITIAL"? id-or-lit) + +(defrule merge-statement + := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail) + +(defrule on-key-phrase + := "ON"? alt-ascending-descending "KEY"? qualified-data-name+) + +(defrule merge-statement-tail + := output-procedure + := giving-file-names) + +(defrule move-statement + := "MOVE" id-or-lit "TO" variable-identifier+ + :reduce (apply #'list 'move id-or-lit variable-identifier) + := "MOVE" corresponding variable-identifier "TO" variable-identifier+ + :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2)) + +(defrule multiply-statement + := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule open-statement + := "OPEN" open-statement-phrase+ + :reduce (list 'open open-statement-phrase)) + +(defrule alt-reversed-with-no-rewind + := "REVERSED" + := with-no-rewind) + +(defrule open-statement-input-file-name + := file-name alt-reversed-with-no-rewind?) + +(defrule with-no-rewind + := "WITH"? "NO" "REWIND") + +(defrule open-statement-output-file-name + := file-name with-no-rewind?) + +(defrule open-statement-input + := "INPUT" open-statement-input-file-name+) + +(defrule open-statement-output + := "OUTPUT" open-statement-output-file-name+) + +(defrule open-statement-i-o + := "I-O" file-name+) + +(defrule open-statement-extend + := "EXTEND" file-name+) + +(defrule open-statement-phrase + := open-statement-input + := open-statement-output + := open-statement-i-o + := open-statement-extend) + +(defrule perform-statement + := "PERFORM" procedure-name through-procedure-name? perform-until-phrase + :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase) + := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase* + :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase) + := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES" + :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name) + := "PERFORM" procedure-name through-procedure-name? + :reduce (append (list 'perform procedure-name) through-procedure-name)) + +(defrule perform-varying-phrase + := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-after-phrase + := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-until-phrase + := with-test? "UNTIL" condition) + +(defrule with-test + := "WITH"? "TEST" alt-before-after + :reduce alt-before-after) + +(defrule read-statement + := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?) + +(defrule key-is-qualified-data-name + := "KEY" "IS"? qualified-data-name) + +(defrule release-statement + := "RELEASE" record-name from-identifier?) + +(defrule return-statement + := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?) + +(defrule into-identifier + := "INTO" variable-identifier) + +(defrule not-at-end-statement-list + := "NOT" "AT"? "END" statement-list) + +(defrule rewrite-statement + := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?) + +(defrule search-statement + := search-statement-1 + := search-statement-2) + +(defrule search-statement-1 + := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?) + +(defrule varying-identifier + := "VARYING" variable-identifier) + +(defrule when-condition-stats + := "WHEN" condition alt-statement-list-next-sentence) + +(defrule search-statement-2 + := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?) + +(defrule at-end-statement-list + := "AT"? "END" statement-list) + +(defrule search-statement-equal-expression + := variable-identifier "IS"? equal-to arithmetic-expression + :reduce (list '= variable-identifier arithmetic-expression)) + +(defrule search-statement-condition + := search-statement-equal-expression + := condition-name-reference) + +(defrule search-statement-condition-tail + := "AND" search-statement-condition) + +(defrule alt-statement-list-next-sentence + := statement+ + := next-sentence + :reduce :next-sentence) + +(defrule set-statement + := "SET" set-statement-phrase+) + +(defrule sort-statement + := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out) + +(defrule key-is + := "KEY" "IS"?) + +(defrule alt-ascending-descending + := "ASCENDING" + := "DESCENDING") + +(defrule on-key-is-phrase + := "ON"? alt-ascending-descending key-is? qualified-data-name+) + +(defrule with-duplicates-in-order + := "WITH"? "DUPLICATES" "IN"? "ORDER"?) + +(defrule collating-sequence + := "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule through + := "THROUGH" + := "THRU") + +(defrule through-procedure-name + := through procedure-name + :reduce procedure-name) + +(defrule using-file-names + := "USING" file-name+) + +(defrule input-procedure + := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule giving-file-names + := "GIVING" file-name+) + +(defrule output-procedure + := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule sort-statement-in + := using-file-names + := input-procedure) + +(defrule sort-statement-out + := giving-file-names + := output-procedure) + +(defrule start-statement + := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?) + +(defrule rel-op + := equal-to + :reduce '= + := greater-than + :reduce '> + := greater-equal + :reduce '>=) + +(defrule key-is-rel-op-qualified-data-name + := "KEY" "IS"? rel-op qualified-data-name + :reduce (list rel-op qualified-data-name)) + +(defrule stop-statement + := "STOP" alt-run-literal + :reduce '(stop)) + +(defrule alt-run-literal + := "RUN" + := literal) + +(defrule string-statement + := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"? + :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit-size + := literal + := variable-identifier + := "SIZE") + +(defrule delimited-by-phrase + := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size + :reduce (list id-or-lit id-or-lit-size)) + +(defrule subtract-statement + := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract id-or-lit cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-corr variable-identifier variable-identifier + :rounded (and $5 t) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule cobword-rounded + := variable-identifier "ROUNDED"? + :reduce (list variable-identifier (and $2 t))) + +(defrule on-size-error-statement-list + := "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule not-on-size-error-statement-list + := "NOT" "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule corresponding + := "CORRESPONDING" + := "CORR") + +(defrule unstring-statement + := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"? + :reduce (list 'unstring variable-identifier unstring-statement-dst + :delimited-by-all delimited-by-all-phrase + :with-pointer with-pointer-identifier + :tallying tallying-in-identifier + :on-overflow on-overflow-statement-list + :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit + := literal + := variable-identifier) + +(defrule or-all-id-or-lit + := "OR" "ALL"? id-or-lit) + +(defrule delimited-by-all-phrase + := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*) + +(defrule delimiter-in-identifier + := "DELIMITER" "IN"? variable-identifier) + +(defrule count-in-identifier + := "COUNT" "IN"? variable-identifier) + +(defrule unstring-statement-dst + := variable-identifier delimiter-in-identifier? count-in-identifier?) + +(defrule with-pointer-identifier + := "WITH"? "POINTER" variable-identifier) + +(defrule tallying-in-identifier + := "TALLYING" "IN"? variable-identifier) + +(defrule on-overflow-statement-list + := "ON"? "OVERFLOW" statement-list) + +(defrule not-on-overflow-statement-list + := "NOT" "ON"? "OVERFLOW" statement-list) + +(defrule write-statement + := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?) + +(defrule lines + := "LINE" + := "LINES") + +(defrule cobword-int + := cobol-identifier + := integer) + +(defrule nr-lines-phrase + := cobword-int lines?) + +(defrule page-phrase + := nr-lines-phrase + := "PAGE") + +(defrule alt-before-after + := "BEFORE" + := "AFTER") + +(defrule advancing-phrase + := alt-before-after "ADVANCING"? page-phrase) + +(defrule from-identifier + := "FROM" variable-identifier) + +(defrule invalid-key-statement-list + := "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule not-invalid-key-statement-list + := "NOT" "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule end-of-page + := "END-OF-PAGE" + := "EOP") + +(defrule at-end-of-page-statement-list + := "AT"? end-of-page statement-list + :reduce statement-list) + +(defrule not-at-end-of-page-statement-list + := "NOT" "AT"? end-of-page statement-list + :reduce statement-list) + +;; This is left in the grammar but is not used. COPYs are handled by +;; the lexical scanner. +(defrule copy-statement + := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?) + +(defrule in + := "OF" + := "IN") + +(defrule alt-library-name-literal + := library-name + := literal) + +(defrule in-library + := in alt-library-name-literal) + +(defrule copy-statement-by-phrase + := copy-operand "BY" copy-operand) + +(defrule copy-statement-replacing-phrase + := "REPLACING" copy-statement-by-phrase+) + +(defrule alt-text-name-literal + := text-name + := literal) + +(defrule copy-operand + := cobol-identifier + := literal) + +(defrule use-statement + := use-statement-1 + := use-statement-2 + := use-statement-3) + +(defrule use-statement-1 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-exception-error + := "EXCEPTION" + := "ERROR") + +(defrule use-statement-2 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-beginning-ending + := "BEGINNING" + := "ENDING") + +(defrule alt-file-reel-unit + := "FILE" + := "REEL" + := "UNIT") + +(defrule file-names + := file-name+) + +(defrule alt-file-names-i-o + := file-names + := "INPUT" + := "OUTPUT" + := "I-O" + := "EXTEND") + +(defrule use-statement-3 + := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures) + +(defrule procedure-names + := procedure-name+) + +(defrule alt-procedures-all-procedures + := procedure-names + := all-procedures) + +(defrule condition + := combinable-condition + := combinable-condition "AND" condition + :reduce `(and ,combinable-condition ,condition) + := combinable-condition "OR" condition + :reduce `(or ,combinable-condition ,condition) + := combinable-condition "AND" id-or-lit + :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)) + := combinable-condition "OR" id-or-lit + :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))) + +(defrule combinable-condition + := "NOT"? simple-condition + :reduce (if $1 + (list 'not simple-condition) + simple-condition)) + +(defrule simple-condition + := class-condition + := relation-condition + := sign-condition + := "(" condition ")" + ;; not sure if it's necessary -wcp15/7/03. + ;; := arithmetic-expression + ) + +(defrule class-condition + := variable-identifier "IS"? "NOT"? class-type + :reduce (if $3 + (list 'not (list 'type-of variable-identifier (make-keyword class-type))) + (list 'type-of variable-identifier (make-keyword class-type)))) + +(defrule class-type + := "NUMERIC" + := "ALPHABETIC" + := "ALPHABETIC-LOWER" + := "ALPHABETIC-UPPER" + := "DBCS") + +(defun unfold-subrelations (main-relation subs) + (destructuring-bind (main-operator main-variable other-variable) main-relation + (declare (ignore other-variable)) + (labels ((unfold (subs) + (if (null subs) + main-relation + (destructuring-bind (connection operator variable) (car subs) + (list connection + (list (or operator main-operator) main-variable variable) + (unfold (cdr subs))))))) + (unfold subs)))) + +(defrule relation-condition + ;; This is too complex + ;; := arithmetic-expression relational-operator simple-condition + := id-or-lit relational-operator id-or-lit subordinate-relation* + :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation)) + +(defrule or-and + := "OR" :reduce 'or + := "AND" :reduce 'and) + +(defrule subordinate-relation + := or-and relational-operator? id-or-lit + :reduce (list or-and relational-operator id-or-lit)) + +(defrule relational-operator + := "IS"? relational-operator-type + :reduce relational-operator-type) + +(defrule less-than + := "LESS" "THAN"? + := "<") + +(defrule greater-equal + := "GREATER" "THAN"? "OR" "EQUAL" "TO"? + := ">=" + := ">" "=" + := "NOT" "<" + := "NOT" "LESS" "THAN"?) + +(defrule less-equal + := "LESS" "THAN"? "OR" "EQUAL" "TO"? + := "<=" + := "<" "=" + := "NOT" ">" + := "NOT" "GREATER" "THAN"?) + +(defrule greater-than + := "GREATER" "THAN"? + := ">") + +(defrule equal-to + := "EQUAL" "TO"? + := "=") + +(defrule relational-operator-type + := greater-equal + :reduce 'cob>= + := less-equal + :reduce 'cob<= + := greater-than + :reduce 'cob> + := less-than + :reduce 'cob< + := equal-to + :reduce 'cob= + := "NOT" equal-to + :reduce 'cob-not=) + +(defrule sign-condition + := arithmetic-expression "IS"? "NOT"? sign-type + :reduce (if $3 + `(not (,sign-type ,arithmetic-expression)) + `(,sign-type ,arithmetic-expression))) + +(defrule sign-type + := "POSITIVE" :reduce '> + := "NEGATIVE" :reduce '< + := "ZERO" :reduce '= + := "ZEROES" :reduce '= + := "ZEROS" :reduce '=) + +(defrule procedure-name + := paragraph-or-section-name in-section-name + :reduce (list paragraph-or-section-name in-section-name) + := paragraph-or-section-name + :reduce paragraph-or-section-name) + +(defrule in-section-name + := in cobol-identifier + :reduce cobol-identifier) + +(defrule variable-identifier + := qualified-data-name subscript-parentheses* ;; reference-modification? + :reduce (if subscript-parentheses + (list :aref qualified-data-name subscript-parentheses) + qualified-data-name)) + +(defrule reference-modification + := "(" leftmost-character-position ":" length? ")" + :reduce (if length + (list :range leftmost-character-position length) + leftmost-character-position)) + +(defrule condition-name-reference + := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*) + +(defrule in-data-or-file-or-mnemonic-name + := in data-or-file-or-mnemonic-name) + +(defrule subscript-parentheses + := "(" subscript ")") + +(defrule subscript + := subscript-expression+) + +(defrule plus-minus-integer + := plus-or-minus integer) + +(defrule subscript-expression-ambiguous + := qualified-data-name plus-minus-integer?) + +(defrule subscript-expression + := literal + := subscript-expression-ambiguous) + +(defrule qualified-data-name + := data-name in-data-or-file-name* + :reduce (if in-data-or-file-name + (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. + data-name) + := "ADDRESS" "OF" data-name + :reduce (list 'address-of data-name) + := "LENGTH" "OF" cobol-identifier + :reduce (list 'length-of cobol-identifier)) + +(defrule in-data-or-file-name + := in data-or-file-name) + +(defrule leftmost-character-position + := arithmetic-expression) + +(defrule length + := arithmetic-expression) + +(defrule arithmetic-expression + := times-div + := times-div "+" arithmetic-expression + :reduce `(+ ,times-div ,arithmetic-expression) + := times-div "-" arithmetic-expression + :reduce `(- ,times-div ,arithmetic-expression)) + +(defrule times-div + := power + := power "*" times-div + :reduce `(* ,power ,times-div) + := power "/" times-div + :reduce `(/ ,power ,times-div)) + +(defrule power + := plus-or-minus? basis + := plus-or-minus? basis "**" power + :reduce (if plus-or-minus + `(plus-or-minus (expt basis basis2)) + `(expt basis basis2))) + +(defrule plus-or-minus + := "+" + :reduce '+ + := "-" + :reduce '-) + +;; (defrule power-tail +;; := "**" basis) + +(defrule basis + := literal + := variable-identifier + := "(" arithmetic-expression ")") + +(defrule alphabet-name + := cobol-identifier) + +(defrule condition-name + := cobol-identifier) + +(defrule data-name + := cobol-identifier) + +(defrule cobol-identifier + := identifier + :reduce (intern (string-upcase identifier))) + +(defrule file-name + := cobol-identifier) + +(defrule data-or-file-name + := cobol-identifier) + +(defrule index-name + := cobol-identifier) + +(defrule mnemonic-name + := cobol-identifier) + +(defrule data-or-file-or-mnemonic-name + := cobol-identifier) + +(defrule record-name + := qualified-data-name) + +(defrule symbolic-character + := cobol-identifier) + +(defrule library-name + := cobol-identifier) + +(defrule program-name + := cobol-identifier + := string) + +(defrule text-name + := cobol-identifier) + +(defrule paragraph-or-section-name + := cobol-identifier + := integer) + +(defrule computer-name + := identifier) + +(defrule environment-name + := cobol-identifier) + +(defrule assignment-name + := cobol-identifier) + +(defrule figurative-constant + := figurative-constant-simple + := figurative-constant-all) + +(defrule figurative-constant-all + := "ALL" literal) + +(defrule literal + := string + := float + := integer + := figurative-constant) + +) ; defun populate-grammar diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd new file mode 100644 index 000000000000..1e35186d6c8c --- /dev/null +++ b/third_party/lisp/npg/npg.asd @@ -0,0 +1,55 @@ +;;; npg.asd --- declaration of this system + +;;; Copyright (C) 2003, 2006 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: npg.asd, Time-stamp: <2006-01-03 17:20:21 wcp> $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :npg-system + (:use :common-lisp :asdf)) + +(in-package :npg-system) + +(defclass sample-file (doc-file) ()) +(defmethod source-file-type ((c sample-file) (s module)) + "lisp") + +(defsystem npg + :name "NPG" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :licence "Lesser General Public License" + :description "NPG a Naive Parser Generator" + :long-description + "NPG is a backtracking recursive descent parser generator for +Common Lisp. It accepts rules in a Lispy EBNF syntax without indirect +left recursive rules." + :components + ((:doc-file "README") + (:doc-file "COPYING") + (:doc-file ".project") + (:module :examples + :components + ((:sample-file "python") + (:sample-file "vs-cobol-ii"))) + (:module :src + :components + ((:file "package") + (:file "common" :depends-on ("package")) + (:file "define" :depends-on ("package" "common")) + (:file "parser" :depends-on ("package" "common")))))) diff --git a/third_party/lisp/npg/src/common.lisp b/third_party/lisp/npg/src/common.lisp new file mode 100644 index 000000000000..8b64f5cc0a7b --- /dev/null +++ b/third_party/lisp/npg/src/common.lisp @@ -0,0 +1,79 @@ +;;; common.lisp --- common stuff + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: common.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +(eval-when (:compile-toplevel :load-toplevel) + (defstruct grammar + rules + keywords + equal-p) + + (defstruct rule + name + productions) + + (defstruct (production (:conc-name prod-)) + tokens + (tokens-length 0 :type fixnum) + action) + + (defstruct token + type ; type of token (identifier, number, ...) + value ; its actual value + position) ; line/column in the input stream + ) ; eval-when + +(defmethod print-object ((obj rule) stream) + (format stream "#R(~A)" (rule-name obj))) + +(defmethod print-object ((obj production) stream) + (format stream "#P(action: ~S)" (prod-action obj))) + +(defmethod print-object ((obj token) stream) + (format stream "#T:~A=~S" (token-type obj) (token-value obj))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-rules-table find-rule add-rule)) + +(defun make-rules-table () + (make-hash-table)) + +(defun find-rule (rule-name rules) + (gethash rule-name rules)) + +(defun add-rule (rule-name rule rules) + (setf (gethash rule-name rules) rule)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-keywords-table find-keyword add-keyword)) + +(defun make-keywords-table () + (make-hash-table :test 'equal)) + +(defun find-keyword (keyword-name keywords) + (gethash keyword-name keywords)) + +(defun add-keyword (keyword keywords) + (setf (gethash keyword keywords) t)) diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp new file mode 100644 index 000000000000..783f071fc5d9 --- /dev/null +++ b/third_party/lisp/npg/src/define.lisp @@ -0,0 +1,408 @@ +;;; define.lisp --- grammar rules definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: define.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *smart-default-reduction* t + "If true the default reductions take only the non-static tokens - +those that are not declared as strings in the grammar.") + +;; These two are filled with DEFRULE. +(defvar *rules* (make-rules-table)) +(defvar *keywords* (make-keywords-table)) + +(defun make-action-arguments (tokens) + "Given a list of tokens making up a production, return three values: +the list of variables for the function reducing this production, those +that are non static and their unambiguous user-friendly names." + (flet ((unique (sym list) + (if (not (assoc sym list)) + sym + (loop + for i of-type fixnum from 2 + for x = (intern (format nil "~:@(~A~)~A" sym i)) + while (assoc x list) + finally (return x))))) + (loop + for tok in tokens + for i of-type fixnum from 1 + for arg = (intern (format nil "$~A" i) (find-package #.*package*)) + collect arg into args + unless (const-terminal-p tok) + collect arg into vars + and when (symbolp tok) + collect (list (unique tok named-vars) arg) into named-vars + when (and (listp tok) + (symbolp (cadr tok))) + collect (list (unique (cadr tok) named-vars) arg) into named-vars + finally + (return (values args vars named-vars))))) + +(defun make-action-function (name tokens action) + "Create a function with name NAME, arguments derived from TOKENS and +body ACTION. Return it's definition." + (let ((function + (multiple-value-bind (args vars named-vars) + (make-action-arguments tokens) + `(lambda ,args + (declare (ignorable ,@args)) + (let (($vars (list ,@vars)) + ($all (list ,@args)) + ,@named-vars + ($alist (list ,@(mapcar #'(lambda (v) + `(cons ',(intern (symbol-name (car v))) + ,(cadr v))) + named-vars)))) + (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) + (flet ((make-object (&optional type args) + (apply #'make-instance (or type ',name) + (append args $alist)))) + ,action)))))) + (when *compile-print* + (if *compile-verbose* + (format t "; Compiling ~S:~% ~S~%" name function) + (format t "; Compiling ~S~%" name))) + (compile name function))) + +(defun define-rule (name productions) + "Accept a rule in EBNF-like syntax, translate it into a sexp and a +call to INSERT-RULE-IN-CURRENT-GRAMMAR." + (flet ((transform (productions) + (loop + for tok in productions + with prod = nil + with action = nil + with phase = nil + with new-prods = nil + while tok + do (cond ((eq tok :=) + (push (list (nreverse prod) action) new-prods) + (setf prod nil + action nil + phase :prod)) + ((eq tok :reduce) + (setf phase :action)) + ((eq tok :tag) + (setf phase :tag)) + ((eq phase :tag) + (setf action `(cons ,tok $vars))) + ((eq phase :action) + (setf action tok)) + ((eq phase :prod) + (push tok prod))) + finally + (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) + (insert-rule-in-current-grammar name (transform productions)))) + +(defmacro defrule (name &rest productions) + "Wrapper macro for DEFINE-RULE." + `(define-rule ',name ',productions)) + +(defun make-optional-rule (token) + "Make a rule for a possibly missing (non)terminal (? syntax) and +return it." + (insert-rule-in-current-grammar + (gensym (concatenate 'string "OPT-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))) + `(((,token)) (())))) + +(defun make-alternative-rule (tokens) + "Make a rule for a list of alternatives (\"or\" syntax) and return it." + (insert-rule-in-current-grammar + (gensym "ALT") + (mapcar #'(lambda (alternative) + `((,alternative))) + tokens))) + +(defun make-nonempty-list-rule (token &optional separator) + "Make a rule for a non-empty list (+ syntax) and return it." + (let ((rule-name (gensym (concatenate 'string "NELST-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))))) + (insert-rule-in-current-grammar + rule-name + (if separator + `(((,token ,separator ,rule-name) + (cons $1 $3)) + ((,token) ,#'list)) + `(((,token ,rule-name) + (cons $1 $2)) + ((,token) ,#'list)))))) + +(defun make-list-rule (token &optional separator) + "Make a rule for a possibly empty list (* syntax) return it." + (make-optional-rule (make-nonempty-list-rule token separator))) + +(defun const-terminal-p (object) + (or (stringp object) + (keywordp object))) + +(defun expand-production-token (tok) + "Translate token of the type NAME? or NAME* or NAME+ into (? NAME) +or (* NAME) or (+ NAME). This is used by the DEFRULE macro." + (if (symbolp tok) + (let* ((name (symbol-name tok)) + (last (char name (1- (length name)))) + ;; this looks silly but we need to make sure that we + ;; return symbols interned in this package, no one else + (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) + (if (and (> (length name) 1) op) + (list op + (intern (subseq name 0 (1- (length name))))) + tok)) + tok)) + +(defun EBNF-to-SEBNF (tokens) + "Take a production as a list of TOKENS and expand it. This turns a +EBNF syntax into a sexp-based EBNF syntax or SEBNF." + (loop + for tok in tokens + for token = (expand-production-token tok) + with new-tokens = '() + do (cond ((member token '(* + ?)) + (setf (car new-tokens) + (list token (car new-tokens)))) + (t + (push token new-tokens))) + finally (return (nreverse new-tokens)))) + +(defun SEBNF-to-BNF (tokens) + "Take a production in SEBNF (Symbolic Extended BNF) syntax and turn +it into BNF. The production is simplified but the current grammar is +populated with additional rules." + (flet ((make-complex-token-rule (tok) + (ecase (car tok) + (* (apply #'make-list-rule (cdr tok))) + (+ (apply #'make-nonempty-list-rule (cdr tok))) + (? (make-optional-rule (cadr tok))) + (or (make-alternative-rule (cdr tok)))))) + (loop + for token in tokens + with new-tokens = '() + with keywords = '() + do (cond ((listp token) + (push (make-complex-token-rule token) new-tokens)) + (t + (push token new-tokens) + (when (const-terminal-p token) + (push token keywords)))) + finally (return (values (nreverse new-tokens) keywords))))) + +(defun make-default-action-function (name tokens) + "Create a sexp to be used as default action in case one is not +supplied in the production. This is usually a quite sensible +one. That is, only the non-constant tokens are returned in a +list and in case only a variable token is available that one is +returned (not included in a list). If all the tokens are +constant, then all of them are returned in a list." + (cond ((null tokens) + ;; if the production matched the empty list (no tokens) we + ;; return always nil, that is the function LIST applied to no + ;; arguments + #'list) + ((null (cdr tokens)) + ;; if the production matches just one token we simply return + ;; that + #'identity) + (*smart-default-reduction* + ;; If we are required to be "smart" then create a function + ;; that simply returns the non static tokens of the + ;; production. If the production doesn't have nonterminal, + ;; then return all the tokens. If the production has only + ;; one argument then return that one only. + (make-action-function name tokens '(cond + ((null $vars) $all) + ((null (cdr $vars)) (car $vars)) + (t $vars)))) + (t + ;; in all the other cases we return all the token matching + ;; the production + #'list))) + +(defun make-production-from-descr (name production-description) + "Take a production NAME and its description in the form of a sexp +and return a production structure object together with a list of used +keywords." + (destructuring-bind (tokens &optional action) production-description + (let ((expanded-tokens (EBNF-to-SEBNF tokens))) + (multiple-value-bind (production-tokens keywords) + (sebnf-to-bnf expanded-tokens) + (let ((funct + (cond ((not action) + (make-default-action-function name expanded-tokens)) + ((or (listp action) + ;; the case when the action is simply to + ;; return a token (ie $2) or a constant value + (symbolp action)) + (make-action-function name expanded-tokens action)) + ((functionp action) + action) + (t ; action is a constant + #'(lambda (&rest args) + (declare (ignore args)) + action))))) + (values + ;; Make a promise instead of actually resolving the + ;; nonterminals. This avoids endless recursion. + (make-production :tokens production-tokens + :tokens-length (length production-tokens) + :action funct) + keywords)))))) + +(defun remove-immediate-left-recursivity (rule) + "Turn left recursive rules of the type + A -> A x | y +into + A -> y A2 + A2 -> x A2 | E +where E is the empty production." + (let ((name (rule-name rule)) + (productions (rule-productions rule))) + (loop + for prod in productions + for tokens = (prod-tokens prod) + ;; when immediately left recursive + when (eq (car tokens) rule) + collect prod into left-recursive + else + collect prod into non-left-recursive + finally + ;; found any left recursive production? + (when left-recursive + (warn "rule ~S is left recursive" name) + (let ((new-rule (make-rule :name (gensym "REWRITE")))) + ;; A -> y A2 + (setf (rule-productions rule) + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append tokens (list new-rule)) + :tokens-length (1+ (prod-tokens-length p)) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + (funcall f-A2 (apply action head))))))) + non-left-recursive)) + ;; A2 -> x A2 | E + (setf (rule-productions new-rule) + (append + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append (cdr tokens) (list new-rule)) + :tokens-length (prod-tokens-length p) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + #'(lambda (x) + (funcall f-A2 (apply action x head)))))))) + left-recursive) + (list + (make-production :tokens nil + :tokens-length 0 + :action #'(lambda () #'(lambda (arg) arg))))))))))) + +(defun remove-left-recursivity-from-rules (rules) + (loop + for rule being each hash-value in rules + do + ;; More to be done here. For now only the trivial immediate left + ;; recursivity is removed -wcp18/11/03. + (remove-immediate-left-recursivity rule))) + +(defun resolve-all-nonterminals (rules) + (loop + for rule being each hash-value in rules + do (loop + for production in (rule-productions rule) + do (setf (prod-tokens production) + (resolve-nonterminals (prod-tokens production) rules))))) + +(defun make-rule-productions (rule-name production-descriptions) + "Return a production object that belongs to RULE-NAME made according +to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR." + (loop + for descr in production-descriptions + for i of-type fixnum from 1 by 1 + for prod-name = (intern (format nil "~:@(~A~)-PROD~A" rule-name i)) + with productions = '() + with keywords = '() + do (progn + (multiple-value-bind (production keyws) + (make-production-from-descr prod-name descr) + (push production productions) + (setf keywords (append keyws keywords)))) + finally (return + (values (nreverse productions) keywords)))) + +(defun create-rule (name production-descriptions) + "Return a new rule object together with a list of keywords making up +the production definitions." + (multiple-value-bind (productions keywords) + (make-rule-productions name production-descriptions) + (values (make-rule :name name :productions productions) + keywords))) + +(defun insert-rule-in-current-grammar (name productions) + "Add rule to the current grammar and its keywords to the keywords +hash table. You don't want to use this directly. See DEFRULE macro +instead." + (when (find-rule name *rules*) + (error "redefining rule ~A" name)) + (multiple-value-bind (rule keywords) + (create-rule name productions) + (add-rule name rule *rules*) + (dolist (term keywords) + (add-keyword term *keywords*)) + rule)) + +(defun resolve-nonterminals (tokens rules) + "Given a list of production tokens, try to expand the nonterminal +ones with their respective rule from the the RULES pool." + (flet ((resolve-symbol (sym) + (or (find-rule sym rules) + sym))) + (mapcar #'(lambda (tok) + (if (symbolp tok) + (resolve-symbol tok) + tok)) + tokens))) + +(defun reset-grammar () + "Empty the current grammar from any existing rule." + (setf *rules* (make-rules-table) + *keywords* (make-keywords-table))) + +(defun generate-grammar (&optional (equal-p #'string-equal)) + "Return a GRAMMAR structure suitable for the PARSE function, using +the current rules. EQUAL-P, if present, is a function to be used to +match the input tokens; it defaults to STRING-EQUAL." + (resolve-all-nonterminals *rules*) + (remove-left-recursivity-from-rules *rules*) + (make-grammar :rules *rules* + :keywords *keywords* + :equal-p equal-p)) diff --git a/third_party/lisp/npg/src/package.lisp b/third_party/lisp/npg/src/package.lisp new file mode 100644 index 000000000000..b405f7b5f19e --- /dev/null +++ b/third_party/lisp/npg/src/package.lisp @@ -0,0 +1,50 @@ +;;; package.lisp --- backtracking parser package definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :naive-parser-generator + (:nicknames :npg) + (:use :common-lisp) + (:export + #:parse ; The Parser + #:reset-grammar + #:generate-grammar + #:print-grammar-figures + #:grammar-keyword-p + #:keyword + #:grammar + #:make-token + #:token-value + #:token-type + #:token-position + #:later-position + #:defrule ; to define grammars + #:deftoken ; to define a lexer + #:input-cursor-mixin + #:copy-input-cursor-slots + #:dup-input-cursor + #:read-next-tokens + #:end-of-input + #:? #:+ #:* #:or + #:$vars #:$all #:$alist + #:$1 #:$2 #:$3 #:$4 #:$5 #:$6 #:$7 #:$8 #:$9 #:$10)) diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp new file mode 100644 index 000000000000..c15d26fe394e --- /dev/null +++ b/third_party/lisp/npg/src/parser.lisp @@ -0,0 +1,234 @@ +;;; parser.lisp --- runtime parser + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: parser.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is the runtime part of the parser. The code that is +;;; responsible to execute the parser defined with the primitives +;;; found in define.lisp. + +(in-package :naive-parser-generator) + +(defvar *debug* nil + "Either nil or a stream where to write the debug informations.") +#+debug (declaim (fixnum *maximum-recursion-depth*)) +#+debug (defvar *maximum-recursion-depth* 1000 + "Maximum depth the parser is allowed to recursively call itself. +This is the only way for the parser to detect a loop in the grammar. +Tune this if your grammar is unusually complex.") + +(declaim (inline reduce-production)) +(defun reduce-production (production arguments) + "Apply PRODUCTION's action on ARGUMENTS. This has the effect of + \"reducing\" the production." + (when *debug* + (format *debug* "reducing ~S on ~S~%" production arguments)) + (flet ((safe-token-value (token) + (if (token-p token) + (token-value token) + token))) + (apply (prod-action production) (mapcar #'safe-token-value arguments)))) + +(defgeneric later-position (pos1 pos2) + (:documentation + "Compare two file postions and return true if POS1 is later than +POS2 in the input stream.")) + +;; This is meant to be overloaded in the lexer +(defmethod later-position ((pos1 integer) (pos2 integer)) + (> pos1 pos2)) + +;; this looks silly but turns out to be useful (see below) +(defmethod later-position (pos1 pos2) + (and (eq pos1 :eof) (not (eq pos2 :eof)))) + +(defgeneric read-next-tokens (tokens-source) + (:documentation "Read next token from a lexical analysed stream. The nature of +TOKENS-SOURCE is implementation dependent and any lexical analyzer is +supposed to specialise this method.")) + +;; This is the actual parser. the algorithm is pretty +;; straightforward, the execution of the reductions a bit less. Error +;; recovery is rather clumsy. + +(defun parse (grammar start tokenizer) + "Match a GRAMMAR against the list of input tokens coming from TOKENIZER. +Return the reduced values according to the nonterminal actions. Raise +an error on failure." + (declare (type grammar grammar) + (type symbol start)) + (labels + ((match-token (expected token) + (when *debug* + (format *debug* "match-token ~S ~S -> " expected token)) + (let ((res (cond ((symbolp expected) + ;; non-costant terminal (like identifiers) + (eq expected (token-type token))) + ((and (stringp expected) + (stringp (token-value token))) + ;; string costant terminal + (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) + ((functionp expected) + ;; custom equality predicate (must be able + ;; to deal with token objects) + (funcall expected token)) + ;; all the rest + (t (equal expected (token-value token)))))) + (when *debug* + (format *debug* "~Amatched~%" (if res "" "not "))) + res)) + (match (expected matched #+debug depth) + (declare (list expected matched) + #+debug (fixnum depth)) + (let ((first-expected (car expected))) + (cond #+debug ((> depth *maximum-recursion-depth*) + (error "endless recursion on ~A ~A at ~A expecting ~S" + (token-type (car matched)) (token-value (car matched)) + (token-position (car matched)) expected)) + ((eq first-expected :any) + (match (cdr expected) (cdr matched) #+debug depth)) + ;; This is a trick to obtain partial parses. When we + ;; reach this expected token we assume we succeeded + ;; the parsing and return the remaining tokens as + ;; part of the match. + ((eq first-expected :rest) + ;; we could be at the end of input so we check this + (unless (cdr matched) + (setf (cdr matched) (list :rest))) + (list nil nil)) + ((rule-p first-expected) + ;; If it's a rule, then we try to match all its + ;; productions. We return the first that succeeds. + (loop + for production in (rule-productions first-expected) + for production-tokens of-type list = (prod-tokens production) + with last-error-position = nil + with last-error = nil + for (error-position error-descr) = + (progn + (when *debug* + (format *debug* "trying to match ~A: ~S~%" + (rule-name first-expected) production-tokens)) + (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) + do (cond ((not error-position) + (return (let ((args-count (prod-tokens-length production))) + (setf (cdr matched) + (cons (reduce-production + production + (subseq (the list (cdr matched)) 0 args-count)) + (nthcdr (1+ args-count) matched))) + (list nil nil)))) + ((or (not last-error) + (later-position error-position last-error-position)) + (setf last-error-position error-position + last-error error-descr))) + ;; if everything fails return the "best" error + finally (return (list last-error-position + (if *debug* + #'(lambda () + (format nil "~A, trying to match ~A" + (funcall (the function last-error)) + (rule-name first-expected))) + last-error))))) + (t + ;; if necessary load the next tokens + (when (null (cdr matched)) + (setf (cdr matched) (read-next-tokens tokenizer))) + (cond ((and (or (null expected) (eq first-expected :eof)) + (null (cdr matched))) + ;; This point is reached only once for each complete + ;; parsing. The expected tokens and the input + ;; tokens have been exhausted at the same time. + ;; Hence we succeeded the parsing. + (setf (cdr matched) (list :eof)) + (list nil nil)) + ((null expected) + ;; Garbage at end of parsing. This may mean that we + ;; have considered a production completed too soon. + (list (token-position (car matched)) + #'(lambda () + "garbage at end of parsing"))) + ((null (cdr matched)) + ;; EOF error + (list :eof + #'(lambda () + (format nil "end of input expecting ~S" expected)))) + (t ;; normal token + (let ((first-token (cadr matched))) + (if (match-token first-expected first-token) + (match (cdr expected) (cdr matched) #+debug depth) + ;; failed: we return the error + (list (token-position first-token) + #'(lambda () + (format nil "expected ~S but got ~S ~S" + first-expected (token-type first-token) + (token-value first-token))))))))))))) + (declare (inline match-token)) + (let ((result (list :head))) + (destructuring-bind (error-position error) + (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) + (when error-position + (error "~A at ~A~%" (funcall (the function error)) error-position)) + (cadr result))))) + +(defgeneric terminals-in-grammar (grammar-or-hashtable) + (:documentation + "Find non constant terminal symbols in GRAMMAR.")) + +(defmethod terminals-in-grammar ((grammar hash-table)) + (loop + for rule being each hash-value of grammar + with terminals = '() + do (loop + for prod in (rule-productions rule) + do (loop + for tok in (prod-tokens prod) + when (symbolp tok) + do (pushnew tok terminals))) + finally (return terminals))) + +(defmethod terminals-in-grammar ((grammar grammar)) + (terminals-in-grammar (grammar-rules grammar))) + +(defun print-grammar-figures (grammar &optional (stream *standard-output*)) + (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%" + (hash-table-count (grammar-rules grammar)) + (hash-table-count (grammar-keywords grammar)) + (terminals-in-grammar (grammar-rules grammar)))) + + +(defun grammar-keyword-p (keyword grammar) + "Check if KEYWORD is part of this grammar." + (find-keyword keyword (grammar-keywords grammar))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *grammars* (make-hash-table)) + +(defun find-grammar (name) + (gethash name *grammars*)) + +(defun delete-grammar (name) + (remhash name *grammars*)) + +(defun add-grammar (name grammar) + (setf (gethash name *grammars*) grammar)) diff --git a/third_party/lisp/parse-float.nix b/third_party/lisp/parse-float.nix new file mode 100644 index 000000000000..e90824108ed1 --- /dev/null +++ b/third_party/lisp/parse-float.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.parse-float; +in depot.nix.buildLisp.library { + name = "parse-float"; + + deps = with depot.third_party.lisp; [ + alexandria + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "parse-float.lisp" + ]; +} diff --git a/third_party/lisp/parse-number.nix b/third_party/lisp/parse-number.nix new file mode 100644 index 000000000000..61b0b1fddbda --- /dev/null +++ b/third_party/lisp/parse-number.nix @@ -0,0 +1,9 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.parse-number; +in depot.nix.buildLisp.library { + name = "parse-number"; + srcs = map (f: src + ("/" + f)) [ + "parse-number.lisp" + ]; +} diff --git a/third_party/lisp/parseq.nix b/third_party/lisp/parseq.nix new file mode 100644 index 000000000000..23c67c2d9c30 --- /dev/null +++ b/third_party/lisp/parseq.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.parseq; +in depot.nix.buildLisp.library { + name = "parseq"; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "conditions.lisp" + "utils.lisp" + "defrule.lisp" + ]; +} diff --git a/third_party/lisp/physical-quantities.nix b/third_party/lisp/physical-quantities.nix new file mode 100644 index 000000000000..d594ff1a1cf7 --- /dev/null +++ b/third_party/lisp/physical-quantities.nix @@ -0,0 +1,24 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.physical-quantities; +in depot.nix.buildLisp.library { + name = "physical-quantities"; + + deps = with depot.third_party.lisp; [ + parseq + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "utils.lisp" + "conditions.lisp" + "unit-factor.lisp" + "unit-database.lisp" + "units.lisp" + "quantity.lisp" + "numeric.lisp" + "parse-rules.lisp" + "read-macro.lisp" + "si-units.lisp" + ]; +} diff --git a/third_party/lisp/postmodern.nix b/third_party/lisp/postmodern.nix new file mode 100644 index 000000000000..25e0625c20bc --- /dev/null +++ b/third_party/lisp/postmodern.nix @@ -0,0 +1,94 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.postmodern; + + cl-postgres = depot.nix.buildLisp.library { + name = "cl-postgres"; + deps = with depot.third_party.lisp; [ + md5 + split-sequence + ironclad + cl-base64 + uax-15 + usocket + ]; + + srcs = map (f: src + ("/cl-postgres/" + f)) [ + "package.lisp" + "features.lisp" + "config.lisp" + "oid.lisp" + "errors.lisp" + "data-types.lisp" + "sql-string.lisp" + "trivial-utf-8.lisp" + "strings-utf-8.lisp" + "communicate.lisp" + "messages.lisp" + "ieee-floats.lisp" + "interpret.lisp" + "saslprep.lisp" + "scram.lisp" + "protocol.lisp" + "public.lisp" + "bulk-copy.lisp" + ]; + }; + + s-sql = depot.nix.buildLisp.library { + name = "s-sql"; + deps = with depot.third_party.lisp; [ + cl-postgres + alexandria + ]; + + srcs = map (f: src + ("/s-sql/" + f)) [ + "package.lisp" + "config.lisp" + "s-sql.lisp" + ]; + }; + + postmodern = depot.nix.buildLisp.library { + name = "postmodern"; + + deps = with depot.third_party.lisp; [ + alexandria + cl-postgres + s-sql + global-vars + split-sequence + cl-unicode + closer-mop + bordeaux-threads + ]; + + srcs = [ + "${src}/postmodern.asd" + ] ++ (map (f: src + ("/postmodern/" + f)) [ + "package.lisp" + "config.lisp" + "connect.lisp" + "json-encoder.lisp" + "query.lisp" + "prepare.lisp" + "roles.lisp" + "util.lisp" + "transaction.lisp" + "namespace.lisp" + "execute-file.lisp" + "table.lisp" + "deftable.lisp" + ]); + + brokenOn = [ + "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651 + ]; + }; + +in +postmodern // { + inherit s-sql cl-postgres; +} diff --git a/third_party/lisp/prove.nix b/third_party/lisp/prove.nix new file mode 100644 index 000000000000..af481499207f --- /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 new file mode 100644 index 000000000000..f7146ba93f1f --- /dev/null +++ b/third_party/lisp/puri.nix @@ -0,0 +1,10 @@ +# Portable URI library +{ depot, pkgs, ... }: + +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 000000000000..5a2f2a9f0864 --- /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 000000000000..40a93e04f062 --- /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/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md new file mode 100644 index 000000000000..2d590a0564ae --- /dev/null +++ b/third_party/lisp/quasiquote_2/README.md @@ -0,0 +1,258 @@ +quasiquote-2.0 +============== + +Why should it be hard to write macros that write other macros? +Well, it shouldn't! + +quasiquote-2.0 defines slightly different rules for quasiquotation, +that make writing macro-writing macros very smooth experience. + +NOTE: quasiquote-2.0 does horrible things to shared structure!!! +(it does a lot of COPY-TREE's, so shared-ness is destroyed). +So, it's indeed a tool to construct code (where it does not matter much if the +structure is shared or not) and not the data (or, at least, not the data with shared structure) + + +```lisp +(quasiquote-2.0:enable-quasiquote-2.0) + +(defmacro define-my-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-expand-to + ,,@body))) ; note the difference from usual way + +(define-my-macro foo (x y) + ,x ; now here injections of quotation constructs work + ,y) + +(define-my-macro bar (&body body) + ,@body) ; splicing is also easy +``` + +The "injections" in macros FOO and BAR work as naively expected, as if I had written +```lisp +(defmacro foo (x y) + `(sample-thing-to-expand-to ,x ,y)) + +(defmacro bar (&body body) + `(sample-thing-to-expand-to ,@body)) + +(macroexpand-1 '(foo a b)) + + '(SAMPLE-THING-TO-EXPAND-TO A B) + +(macroexpand-1 '(bar a b c)) + + '(SAMPLE-THING-TO-EXPAND-TO A B C) +``` + + +So, how is this effect achieved? + + +DIG, INJECT and SPLICE +------------------------- + +The transformations of backquote occur at macroexpansion-time and not at read-time. +It is totally possible not to use any special reader syntax, but just +underlying macros directly! + +At the core is a macro DIG, which expands to the code that generates the +expression according to the rules, which are roughly these: + * each DIG increases "depth" by one (hence the name) + * each INJECT or SPLICE decreases "depth" by one + * if depth is 0, evaluation is turned on + * if depth if not zero (even if it's negative!) evaluation is off + * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,` + +```lisp +;; The example using macros, without special reader syntax + +(dig ; depth is 1 here + (a b + (dig ; depth is 2 here + ((inject c) ; this inject is not evaluated, because depth is nonzero + (inject (d ;depth becomes 1 here again + (inject e) ; and this inject is evaluated, because depth becomes zero + )) + (inject 2 f) ; this inject with level specification is evaluated, because it + ; decreases depth by 2 + )))) + + +;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as +`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually +``` + + +The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads +`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM). +You can just as well type DIG's, INJECT's and SPLICE's directly, +(in particular, when writing utility functions that generate macro-generating code) +or roll your own convenient reader syntax (pull requests are welcome). + +So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same +```lisp +`(a (,b `,,c) d) + +(dig (a ((inject b) (dig (inject 2 c))) d)) +``` + +You may notice the (INJECT 2 ...) form appearing, which is described below. + + +At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@ +this behaves exactly as usual quasiquotation. + + +The optional N argument +-------------- + +All quasiquote-2.0 operators accept optional "depth" argument, +which goes before the form for human readability. + +Namely, (DIG N FORM) increases depth by N instead of one and +(INJECT N FORM) decreases depth by N instead of one. + +```lisp +(DIG 2 (INJECT 2 A)) + +; gives the same result as + +(DIG (INJECT A)) +``` + + +In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM) +and ,,,,,@FORM as (SPLICE 5 FORM) + + +More examples +------------- + +For fairly complicated example, which uses ,,,@ and OINJECT (see below), + see DEFINE-BINOP-DEFINER macro +in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp), +desire to write which was the initial impulse for this project. + + +For macro, that is not a macro-writing macro, yet benefits from +ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro +(also from CG-LLVM) + +```lisp +(defmacro joining-with-comma-space (&body body) + ;; joinl just joins strings in the list with specified string + `(joinl ", " (mapcar #'emit-text-repr + (remove-if-not #'identity `(,,@body))))) + +;; the macro can be then used uniformly over strings and lists of strings +(defun foo (x y &rest z) + (joining-with-comma-space ,x ,y ,@z)) + +(foo "a" "b" "c" "d") + ;; produces + "a, b, c, d" +``` + + +ODIG and OINJECT and OSPLICE +---------------------------- + +Sometimes you don't want DIG's macroexpansion to look further into the structure of +some INJECT or SPLICE or DIG in its subform, +if the depth does not match. In these cases you need "opaque" versions of +DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE. + +```lisp +;; here injection of B would occur +(defun foo (b) + (dig (dig (inject (a (inject b)))))) + +;; and here not, because macroexpansion does not look into OINJECT form +(defun bar (b) + (dig (dig (oinject (a (inject b)))))) + +(foo 1) + + '(DIG (INJECT (A 1))) + +(bar 1) + + '(DIG (OINJECT (A (INJECT B)))) +``` + +MACRO-INJECT and MACRO-SPLICE +----------------------------- + +Sometimes you just want to abstract-out some common injection patterns... +That is, you want macros, that expand into common injection patterns. +However, you want this only sometimes, and only in special circumstances. +So it won't do, if INJECT and SPLICE just expanded something, whenever it +turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE. + +```lisp +;; with quasiquote-2.0 syntax turned on +(defmacro inject-n-times (form n) + (make-list n :initial-element `(inject ,form))) + +(let (x 0) + `(dig (a (macro-inject (inject-n-times (incf x) 3))))) +;; yields +'(a (1 2 3)) + +;;and same with MACRO-SPLICE +(let (x 0) + `(dig (a (macro-splice (inject-n-times (incf x) 3))))) +;; yields +'(a 1 2 3) +``` + +OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE. + +Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1), +before plugging it into list. +If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL, +which expand using MACROEXPAND before injecting/splicing, respectively. +That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be +macro-form, the subform of MACRO-INJECT-ALL is not. + + +Terse syntax of the ENABLE-QUASIQUOTE-2.0 +----------------------------------------- + +Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly +every time you want this special things is kind of clumsy. For that, default reader +of quasiquote-2.0 provides extended syntax + +```lisp +',,,,!oma@x + +;; reads as +'(OMACRO-SPLICE-ALL 4 X) +``` + +That is, the regexp of the syntax is +[,]+![o][m][a][@]<whatever> + +As usual, number of commas determine the anti-depth of the injector, exclamation mark +turns on the syntax, if `o` is present, opaque version of injector will be used, +if `m` is present, macro-expanding version of injector will be used and if +`a` is present, macro-all version of injector will be used. + +Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but +this will not correspond to the actual macro name. + +Note: it was necessary to introduce special escape-char for extended syntax, +since usual idioms like `,args` would otherwise be completely screwed. + + +TODO +---- + +* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading +* wrappers for convenient definition of custom overloading schemes +* some syntax for opaque operations + +P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com + and has nothing to do with being "the 2.0" version of quasiquote. \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/default.nix b/third_party/lisp/quasiquote_2/default.nix new file mode 100644 index 000000000000..521c384787fe --- /dev/null +++ b/third_party/lisp/quasiquote_2/default.nix @@ -0,0 +1,17 @@ +# Quasiquote more suitable for macros that define other macros +{ depot, ... }: + +depot.nix.buildLisp.library { + name = "quasiquote-2.0"; + + deps = [ + depot.third_party.lisp.iterate + ]; + + srcs = [ + ./package.lisp + ./quasiquote-2.0.lisp + ./macros.lisp + ./readers.lisp + ]; +} diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp new file mode 100644 index 000000000000..6ebeb47d081e --- /dev/null +++ b/third_party/lisp/quasiquote_2/macros.lisp @@ -0,0 +1,15 @@ + +(in-package #:quasiquote-2.0) + +(defmacro define-dig-like-macro (name) + `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env) + (if (not form-p) + `(,',name 1 ,n-or-form) + (let ((*env* env)) + (transform-dig-form `(,',name ,n-or-form ,form)))))) + + +(define-dig-like-macro dig) +(define-dig-like-macro odig) + + diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp new file mode 100644 index 000000000000..9b140ef84c32 --- /dev/null +++ b/third_party/lisp/quasiquote_2/package.lisp @@ -0,0 +1,11 @@ +;;;; package.lisp + +(defpackage #:quasiquote-2.0 + (:use #:cl #:iterate) + (:export #:%codewalk-dig-form #:transform-dig-form + #:dig #:inject #:splice #:odig #:oinject #:osplice + #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice + #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all + #:enable-quasiquote-2.0 #:disable-quasiquote-2.0)) + + diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd new file mode 100644 index 000000000000..3acfd32b80e6 --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd @@ -0,0 +1,30 @@ +;;;; quasiquote-2.0.asd + +(defpackage :quasiquote-2.0-system + (:use :cl :asdf)) + +(in-package quasiquote-2.0-system) + +(asdf:defsystem #:quasiquote-2.0 + :serial t + :description "Writing macros that write macros. Effortless." + :author "Alexandr Popolitov <popolit@gmail.com>" + :license "MIT" + :version "0.3" + :depends-on (#:iterate) + :components ((:file "package") + (:file "quasiquote-2.0") + (:file "macros") + (:file "readers"))) + +(defsystem :quasiquote-2.0-tests + :description "Tests for QUASIQUOTE-2.0" + :licence "MIT" + :depends-on (:quasiquote-2.0 :fiveam) + :components ((:file "tests") + (:file "tests-macro") + )) + +(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0)))) + (load-system :quasiquote-2.0) + (funcall (intern "RUN-TESTS" :quasiquote-2.0))) diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp new file mode 100644 index 000000000000..10043fe0ecbc --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp @@ -0,0 +1,340 @@ +;;;; quasiquote-2.0.lisp + +(in-package #:quasiquote-2.0) + +(defparameter *env* nil) + +(defmacro nonsense-error (str) + `(error ,(concatenate 'string + str + " appears as a bare, non DIG-enclosed form. " + "For now I don't know how to make sense of this."))) + +(defmacro define-nonsense-when-bare (name) + `(defmacro ,name (n-or-form &optional form) + (declare (ignore n-or-form form)) + (nonsense-error ,(string name)))) + +(define-nonsense-when-bare inject) +(define-nonsense-when-bare oinject) +(define-nonsense-when-bare splice) +(define-nonsense-when-bare osplice) +(define-nonsense-when-bare macro-inject) + +(defparameter *depth* 0) + + +(defparameter *injectors* nil) + +(defparameter *void-elt* nil) +(defparameter *void-filter-needed* nil) + +;; (defmacro with-injector-parsed (form) +;; `(let ((kwd (intern (string + +(defun reset-injectors () + (setf *injectors* nil)) + +(defparameter *known-injectors* '(inject splice oinject osplice + macro-inject omacro-inject + macro-splice omacro-splice + macro-inject-all omacro-inject-all + macro-splice-all omacro-splice-all)) + +(defun injector-form-p (form) + (and (consp form) + (find (car form) *known-injectors* :test #'eq))) + +(defun injector-level (form) + (if (equal 2 (length form)) + 1 + (cadr form))) + +(defun injector-subform (form) + (if (equal 2 (length form)) + (values (cdr form) '(cdr)) + (values (cddr form) '(cddr)))) + +(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject)) + +(defun transparent-p (form) + (not (find (car form) *opaque-injectors* :test #'eq))) + +(defun look-into-injector (form path) + (let ((*depth* (- *depth* (injector-level form)))) + (multiple-value-bind (subform subpath) (injector-subform form) + (search-all-active-sites subform (append subpath path) nil)))) + +(defparameter *known-diggers* '(dig odig)) + +(defun dig-form-p (form) + (and (consp form) + (find (car form) *known-diggers* :test #'eq))) + +(defun look-into-dig (form path) + (let ((*depth* (+ *depth* (injector-level form)))) + (multiple-value-bind (subform subpath) (injector-subform form) + (search-all-active-sites subform (append subpath path) nil)))) + +(defun handle-macro-1 (form) + (if (atom form) + (error "Sorry, symbol-macros are not implemented for now") + (let ((fun (macro-function (car form) *env*))) + (if (not fun) + (error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong...")) + (macroexpand-1 form *env*)))) + +(defun handle-macro-all (form) + (if (atom form) + (error "Sorry, symbol-macros are not implemented for now") + (macroexpand form *env*))) + + +(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1) + (omacro-inject . ,#'handle-macro-1) + (macro-splice . ,#'handle-macro-1) + (omacro-splice . ,#'handle-macro-1) + (macro-inject-all . ,#'handle-macro-all) + (omacro-inject-all . ,#'handle-macro-all) + (macro-splice-all . ,#'handle-macro-all) + (omacro-splice-all . ,#'handle-macro-all))) + +(defun get-macro-handler (sym) + (or (cdr (assoc sym *macro-handlers*)) + (error "Don't know how to handle this macro injector: ~a" sym))) + + + +(defun macroexpand-macroinjector (place) + (if (not (splicing-injector (car place))) + (progn (setf (car place) (funcall (get-macro-handler (caar place)) + (car (injector-subform (car place))))) + nil) + (let ((new-forms (funcall (get-macro-handler (caar place)) + (car (injector-subform (car place)))))) + (cond ((not new-forms) + (setf *void-filter-needed* t + (car place) *void-elt*)) + ((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms)) + (t (setf (car place) (car new-forms)) + (let ((tail (cdr place))) + (setf (cdr place) (cdr new-forms) + (cdr (last new-forms)) tail)))) + t))) + + +(defun search-all-active-sites (form path toplevel-p) + ;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form) + (if (not form) + nil + (if toplevel-p + (cond ((atom (car form)) :just-quote-it!) + ((injector-form-p (car form)) (if (equal *depth* (injector-level (car form))) + :just-form-it! + (if (transparent-p (car form)) + (look-into-injector (car form) (cons 'car path))))) + ((dig-form-p (car form)) + ;; (format t "Got dig form ~a~%" form) + (if (transparent-p (car form)) + (look-into-dig (car form) (cons 'car path)))) + (t (search-all-active-sites (car form) (cons 'car path) nil) + (search-all-active-sites (cdr form) (cons 'cdr path) nil))) + (when (consp form) + (cond ((dig-form-p (car form)) + ;; (format t "Got dig form ~a~%" form) + (if (transparent-p (car form)) + (look-into-dig (car form) (cons 'car path)))) + ((injector-form-p (car form)) + ;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form))) + (if (equal *depth* (injector-level (car form))) + (if (macro-injector-p (car form)) + (progn (macroexpand-macroinjector form) + (return-from search-all-active-sites + (search-all-active-sites form path nil))) + (progn (push (cons form (cons 'car path)) *injectors*) + nil)) + (if (transparent-p (car form)) + (look-into-injector (car form) (cons 'car path))))) + (t (search-all-active-sites (car form) (cons 'car path) nil))) + (search-all-active-sites (cdr form) (cons 'cdr path) nil))))) + + + +(defun codewalk-dig-form (form) + (reset-injectors) + (let ((it (search-all-active-sites form nil t))) + (values (nreverse *injectors*) it))) + +(defun %codewalk-dig-form (form) + (if (not (dig-form-p form)) + (error "Supposed to be called on dig form") + (let ((*depth* (+ (injector-level form) *depth*))) + (codewalk-dig-form (injector-subform form))))) + +(defun path->setfable (path var) + (let ((res var)) + ;; First element is artifact of extra CAR-ing + (dolist (spec (cdr (reverse path))) + (setf res (list spec res))) + res)) + +(defun tree->cons-code (tree) + (if (atom tree) + `(quote ,tree) + `(cons ,(tree->cons-code (car tree)) + ,(tree->cons-code (cdr tree))))) + +(defparameter *known-splicers* '(splice osplice + macro-splice omacro-splice + macro-splice-all omacro-splice-all)) + +(defun splicing-injector (form) + (and (consp form) + (find (car form) *known-splicers* :test #'eq))) + +(defparameter *known-macro-injectors* '(macro-inject omacro-inject + macro-splice omacro-splice + macro-inject-all omacro-inject-all + macro-splice-all omacro-splice-all + )) + +(defun macro-injector-p (form) + (and (consp form) + (find (car form) *known-macro-injectors* :test #'eq))) + +(defun filter-out-voids (lst void-sym) + (let (caars cadrs cdars cddrs) + ;; search for all occurences of VOID + (labels ((rec (x) + (if (consp x) + (progn (cond ((consp (car x)) + (cond ((eq void-sym (caar x)) (push x caars)) + ((eq void-sym (cdar x)) (push x cdars)))) + ((consp (cdr x)) + (cond ((eq void-sym (cadr x)) (push x cadrs)) + ((eq void-sym (cddr x)) (push x cddrs))))) + (rec (car x)) + (rec (cdr x)))))) + (rec lst)) + (if (or cdars cddrs) + (error "Void sym found on CDR position, which should not have happened")) + ;; destructively transform LST + (dolist (elt caars) + (setf (car elt) (cdar elt))) + (dolist (elt cadrs) + (setf (cdr elt) (cddr elt))) + ;; check that we indeed filtered-out all VOIDs + (labels ((rec (x) + (if (not (atom x)) + (progn (rec (car x)) + (rec (cdr x))) + (if (eq void-sym x) + (error "Not all VOIDs were filtered"))))) + (rec lst)) + lst)) + +(defun transform-dig-form (form) + (let ((the-form (copy-tree form))) + (let ((*void-filter-needed* nil) + (*void-elt* (gensym "VOID"))) + (multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form) + (cond ((eq cmd :just-quote-it!) + `(quote ,(car (injector-subform the-form)))) + ((eq cmd :just-form-it!) + (car (injector-subform (car (injector-subform the-form))))) + (t (let ((cons-code (if (not site-paths) + (tree->cons-code (car (injector-subform the-form))) + (really-transform-dig-form the-form site-paths)))) + (if (not *void-filter-needed*) + cons-code + `(filter-out-voids ,cons-code ',*void-elt*))))))))) + +(defmacro make-list-form (o!-n form) + (let ((g!-n (gensym "N")) + (g!-i (gensym "I")) + (g!-res (gensym "RES"))) + `(let ((,g!-n ,o!-n) + (,g!-res nil)) + (dotimes (,g!-i ,g!-n) + (push ,form ,g!-res)) + (nreverse ,g!-res)))) + +(defun mk-splicing-injector-let (x) + `(let ((it ,(car (injector-subform x)))) + (assert (listp it)) + (copy-list it))) + + + +(defun mk-splicing-injector-setf (path g!-list g!-splicee) + (assert (eq 'car (car path))) + (let ((g!-rest (gensym "REST"))) + `(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list))) + (assert (or (not ,g!-rest) (consp ,g!-rest))) + (if (not ,g!-splicee) + (setf ,(path->setfable (cdr path) g!-list) + ,g!-rest) + (progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee) + (setf (cdr (last ,g!-splicee)) ,g!-rest)))))) + + +(defun really-transform-dig-form (the-form site-paths) + (let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE")))) + (let ((g!-list (gensym "LIST"))) + (let ((lets nil) + (splicing-setfs nil) + (setfs nil)) + (do ((site-path site-paths (cdr site-path)) + (gensym gensyms (cdr gensym))) + ((not site-path)) + (destructuring-bind (site . path) (car site-path) + (push `(,(car gensym) ,(if (not (splicing-injector (car site))) + (car (injector-subform (car site))) + (mk-splicing-injector-let (car site)))) + lets) + (if (not (splicing-injector (car site))) + (push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs) + (push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs)) + (setf (car site) nil))) + `(let ,(nreverse lets) + (let ((,g!-list ,(tree->cons-code (car (injector-subform the-form))))) + ,@(nreverse setfs) + ;; we apply splicing setf in reverse order for them not to bork the paths of each other + ,@splicing-setfs + ,g!-list)))))) + + +;; There are few types of recursive injection that may happen: +;; * compile-time injection: +;; (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions +;; * run-time injection: +;; (dig (dig (inject 2 a))) +;; and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it +;; -- do not warn about it, and then it wont really happen. +;; * macroexpanded compile-time injection: +;; (dig (inject (my-macro a b c))), +;; where MY-MACRO expands into, say (splice (list 'a 'b 'c)) +;; This is *not* handled automatically, and therefore we must do it by hand. + + +;; OK, now how to implement splicing ? +;; (dig (a (splice (list b c)) d)) +;; should transform into code that yields +;; (a b c d) +;; what this code is? +;; (let ((#:a (copy-list (list b c)))) +;; (let ((#:res (cons 'a nil 'd))) +;; ;; all non-splicing injects go here, as they do not spoil the path-structure +;; (setf (cdr #:res) #:a) +;; (setf (cdr (last #:a)) (cdr (cdr #:res))) +;; #:res))) + + +;; How this macroexpansion should work in general? +;; * We go over the cons-tree, keeping track of the depth level, which is +;; controlled by DIG's +;; * Once we find the INJECT with matching level, we remember the place, where +;; this happens +;; * We have two special cases: +;; * cons-tree is an atom +;; * cons-tree is just a single INJECT diff --git a/third_party/lisp/quasiquote_2/readers.lisp b/third_party/lisp/quasiquote_2/readers.lisp new file mode 100644 index 000000000000..7c4c5a30c98e --- /dev/null +++ b/third_party/lisp/quasiquote_2/readers.lisp @@ -0,0 +1,77 @@ + + +(in-package #:quasiquote-2.0) + +(defun read-n-chars (stream char) + (let (new-char + (n 0)) + (loop + (setf new-char (read-char stream nil :eof t)) + (if (not (char= new-char char)) + (progn (unread-char new-char stream) + (return n)) + (incf n))))) + +(defmacro define-dig-reader (name symbol) + `(defun ,name (stream char) + (let ((depth (1+ (read-n-chars stream char)))) + (if (equal 1 depth) + (list ',symbol (read stream t nil t)) + (list ',symbol + depth + (read stream t nil t)))))) + +(define-dig-reader dig-reader dig) +(define-dig-reader odig-reader odig) + +(defun expect-char (char stream) + (let ((new-char (read-char stream t nil t))) + (if (char= char new-char) + t + (unread-char new-char stream)))) + +(defun guess-injector-name (opaque-p macro-p all-p splicing-p) + (intern (concatenate 'string + (if opaque-p "O" "") + (if macro-p "MACRO-" "") + (if splicing-p "SPLICE" "INJECT") + (if all-p "-ALL" "")) + "QUASIQUOTE-2.0")) + +(defun inject-reader (stream char) + (let ((anti-depth (1+ (read-n-chars stream char))) + (extended-syntax (expect-char #\! stream))) + (let ((injector-name (if (not extended-syntax) + (guess-injector-name nil nil nil (expect-char #\@ stream)) + (guess-injector-name (expect-char #\o stream) + (expect-char #\m stream) + (expect-char #\a stream) + (expect-char #\@ stream))))) + `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth)) + ,(read stream t nil t))))) + + + +(defvar *previous-readtables* nil) + +(defun %enable-quasiquote-2.0 () + (push *readtable* + *previous-readtables*) + (setq *readtable* (copy-readtable)) + (set-macro-character #\` #'dig-reader) + (set-macro-character #\, #'inject-reader) + (values)) + +(defun %disable-quasiquote-2.0 () + (if *previous-readtables* + (setf *readtable* (pop *previous-readtables*)) + (setf *readtable* (copy-readtable nil))) + (values)) + +(defmacro enable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-quasiquote-2.0))) +(defmacro disable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-quasiquote-2.0))) + diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp new file mode 100644 index 000000000000..df6c43e21d77 --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests-macro.lisp @@ -0,0 +1,21 @@ + +(in-package #:quasiquote-2.0-tests) + +(in-suite quasiquote-2.0) + +(enable-quasiquote-2.0) + +(defmacro define-sample-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-macroexpand-to + ,,@body))) + +(define-sample-macro sample-macro-1 (x y) + ,x ,y) + +(define-sample-macro sample-macro-2 (&body body) + ,@body) + +(test macro-defined-macroexpansions + (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b)))) + (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c))))) \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp new file mode 100644 index 000000000000..6c8ab08cc1af --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests.lisp @@ -0,0 +1,143 @@ +(in-package :cl-user) + +(defpackage :quasiquote-2.0-tests + (:use :cl :quasiquote-2.0 :fiveam) + (:export #:run-tests)) + +(in-package :quasiquote-2.0-tests) + +(def-suite quasiquote-2.0) +(in-suite quasiquote-2.0) + +(defun run-tests () + (let ((results (run 'quasiquote-2.0))) + (fiveam:explain! results) + (unless (fiveam:results-status results) + (error "Tests failed.")))) + +(test basic + (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a)))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a)))))) + (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d))))))) + (is (equal '(nil nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d)))))))) + (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d))))))))) + +(test transform + (is (equal '(quote a) (transform-dig-form '(dig a)))) + (is (equal '(quote a) (transform-dig-form '(dig 2 a)))) + (is (equal 'a (transform-dig-form '(dig (inject a))))) + (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a)))))) + +(defun foo (b d) + (dig (a (inject b) c (inject d)))) + +(defun foo1-transparent (x) + (declare (ignorable x)) + (dig (dig (a (inject (b (inject x) c)))))) + +(defun foo1-opaque (x) + (declare (ignorable x)) + (dig (dig (a (oinject (b (inject x) c)))))) + +(defun foo-recursive (x y) + (dig (a (inject (list x (dig (c (inject y)))))))) + + +(test foos + (is (equal '(a 1 c 2) (foo 1 2))) + (is (equal '(a 100 c 200) (foo 100 200)))) + +(test opaque-vs-transparent + (is (equal '(quote a) (transform-dig-form '(odig a)))) + (is (equal '(quote a) (transform-dig-form '(odig 2 a)))) + (is (equal 'a (transform-dig-form '(odig (inject a))))) + (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a))))) + (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a))))))) + (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3))) + (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3)))) + +(test recursive-compile-time + (is (equal '(a (1 (c 2))) (foo-recursive 1 2)))) + + +(test splicing + (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d)))))) + (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d)))))) + (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c)))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b)))))) + (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b)))))) + (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil))))))) + (is (equal '() (eval (transform-dig-form '(dig ((splice nil))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b))))))))) + + +(test are-they-macro + (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b)))))) + (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b))))))) + + +(defmacro triple-var (x) + `((inject ,x) (inject ,x) (inject ,x))) + +(test correct-order-of-effects + (is (equal '(a 1 2 3) (let ((x 0)) + (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x))))))) + (is (equal '(a (((1))) 2) + (let ((x 0)) + (dig (a ((((inject (incf x))))) (inject (incf x)))))))) + +(test macro-injects + (is (equal '(a (3 3 3)) (let ((x 3)) + (dig (a (macro-inject (triple-var x))))))) + (is (equal '(a (1 2 3)) (let ((x 0)) + (dig (a (macro-inject (triple-var (incf x)))))))) + (macrolet ((frob (form n) + (mapcar (lambda (x) + `(inject ,x)) + (make-list n :initial-element form))) + (frob1 (form) + `(frob ,form 4))) + (is (equal '(a (1 2 3 4 5)) + (let ((x 0)) + (dig (a (macro-inject (frob (incf x) 5))))))) + (is (equal '(a 1 2 3 4 5) + (let ((x 0)) + (dig (a (macro-splice (frob (incf x) 5))))))) + (is (equal '(a) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob (incf x) 0))))))) + (is (equal '(a frob (incf x) 4) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob1 (incf x)))))))) + (is (equal '(a 1 2 3 4) + (let ((x 0)) + (dig (a (macro-splice-all (frob1 (incf x)))))))))) + + +(quasiquote-2.0:enable-quasiquote-2.0) + +(test reader + (is (equal '(inject x) ',x)) + (is (equal '(inject 3 x) ',,,x)) + (is (equal '(splice x) ',@x)) + (is (equal '(splice 3 x) ',,,@x)) + (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x)) + (is (equal '(inject 4 oma@x) ',,,,oma@x))) + +(test macro-splices + (macrolet ((splicer (x) + ``(splice ,x))) + (is (equal '(a 1 2 3) (let ((x '(1 2 3))) + `(a ,!m(splicer x))))))) + +(test repeated-splices + (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil))) + (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g))))) + + \ No newline at end of file diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix new file mode 100644 index 000000000000..b82a490c9d71 --- /dev/null +++ b/third_party/lisp/rfc2388.nix @@ -0,0 +1,12 @@ +# Implementation of RFC2388 (multipart/form-data) +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.rfc2388; +in depot.nix.buildLisp.library { + name = "rfc2388"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "rfc2388.lisp" + ]; +} diff --git a/third_party/lisp/routes.nix b/third_party/lisp/routes.nix new file mode 100644 index 000000000000..fc7d4e306713 --- /dev/null +++ b/third_party/lisp/routes.nix @@ -0,0 +1,39 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.applyPatches { + name = "routes-source"; + src = pkgs.fetchFromGitHub { + owner = "archimag"; + repo = "cl-routes"; + rev = "1b79e85aa653e1ec87e21ca745abe51547866fa9"; + sha256 = "1zpk3cp2v8hm50ppjl10yxr437vv4552r8hylvizglzrq2ibsbr1"; + }; + + patches = [ + (pkgs.fetchpatch { + name = "fix-build-with-ccl.patch"; + url = "https://github.com/archimag/cl-routes/commit/2296cdc316ef8e34310f2718b5d35a30040deee0.patch"; + sha256 = "007c19kmymalam3v6l6y2qzch8xs3xnphrcclk1jrpggvigcmhax"; + }) + ]; + }; + +in +depot.nix.buildLisp.library { + name = "routes"; + + deps = with depot.third_party.lisp; [ + puri + iterate + split-sequence + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "uri-template.lisp" + "route.lisp" + "mapper.lisp" + ]; +} diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix new file mode 100644 index 000000000000..9c4da4a02b25 --- /dev/null +++ b/third_party/lisp/s-sysdeps.nix @@ -0,0 +1,18 @@ +# A Common Lisp abstraction layer over platform dependent functionality. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.s-sysdeps; +in depot.nix.buildLisp.library { + name = "s-sysdeps"; + + srcs = [ + "${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/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 000000000000..9e5838c3c545 --- /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/default.nix b/third_party/lisp/s-xml/default.nix new file mode 100644 index 000000000000..486e1c1ac8d3 --- /dev/null +++ b/third_party/lisp/s-xml/default.nix @@ -0,0 +1,25 @@ +# XML serialiser for Common Lisp. +{ 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 = 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/split-sequence.nix b/third_party/lisp/split-sequence.nix new file mode 100644 index 000000000000..4e8f723c3182 --- /dev/null +++ b/third_party/lisp/split-sequence.nix @@ -0,0 +1,15 @@ +# split-sequence is a library for, well, splitting sequences apparently. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.split-sequence; +in depot.nix.buildLisp.library { + name = "split-sequence"; + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "vector.lisp" + "list.lisp" + "extended-sequence.lisp" + "api.lisp" + "documentation.lisp" + ]; +} diff --git a/third_party/lisp/trivial-backtrace.nix b/third_party/lisp/trivial-backtrace.nix new file mode 100644 index 000000000000..27949e8be1e4 --- /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-features.nix b/third_party/lisp/trivial-features.nix new file mode 100644 index 000000000000..02abac54a853 --- /dev/null +++ b/third_party/lisp/trivial-features.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-features; +in depot.nix.buildLisp.library { + name = "trivial-features"; + srcs = [ + { + sbcl = src + "/src/tf-sbcl.lisp"; + ecl = src + "/src/tf-ecl.lisp"; + ccl = src + "/src/tf-openmcl.lisp"; + } + ]; +} diff --git a/third_party/lisp/trivial-garbage.nix b/third_party/lisp/trivial-garbage.nix new file mode 100644 index 000000000000..74224df60d91 --- /dev/null +++ b/third_party/lisp/trivial-garbage.nix @@ -0,0 +1,9 @@ +# trivial-garbage provides a portable API to finalizers, weak +# hash-tables and weak pointers +{ depot, pkgs, ... }: + +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 new file mode 100644 index 000000000000..62a30f1e94f3 --- /dev/null +++ b/third_party/lisp/trivial-gray-streams.nix @@ -0,0 +1,13 @@ +# Portability library for CL gray streams. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-gray-streams; +in depot.nix.buildLisp.library { + name = "trivial-gray-streams"; + srcs = [ + (src + "/package.lisp") + (src + "/streams.lisp") + ]; +} + + diff --git a/third_party/lisp/trivial-indent.nix b/third_party/lisp/trivial-indent.nix new file mode 100644 index 000000000000..70a6e19d48a9 --- /dev/null +++ b/third_party/lisp/trivial-indent.nix @@ -0,0 +1,10 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-indent; +in depot.nix.buildLisp.library { + name = "trivial-indent"; + + srcs = map (f: src + ("/" + f)) [ + "indent.lisp" + ]; +} diff --git a/third_party/lisp/trivial-ldap.nix b/third_party/lisp/trivial-ldap.nix new file mode 100644 index 000000000000..c85fe2accbb9 --- /dev/null +++ b/third_party/lisp/trivial-ldap.nix @@ -0,0 +1,28 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "rwiker"; + repo = "trivial-ldap"; + rev = "3b8f1ff85f29ea63e6ab2d0d27029d68b046faf8"; + sha256 = "1zaa4wnk5y5ff211pkg6dl27j4pjwh56hq0246slxsdxv6kvp1z9"; + }; +in +depot.nix.buildLisp.library { + name = "trivial-ldap"; + + deps = with depot.third_party.lisp; [ + usocket + cl-plus-ssl + cl-yacc + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "trivial-ldap.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/trivial-mimes.nix b/third_party/lisp/trivial-mimes.nix new file mode 100644 index 000000000000..b097a3d0ee67 --- /dev/null +++ b/third_party/lisp/trivial-mimes.nix @@ -0,0 +1,26 @@ +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.trivial-mimes; + + mime-types = pkgs.runCommand "mime-types.lisp" { } '' + substitute ${src}/mime-types.lisp $out \ + --replace /etc/mime.types ${src}/mime.types \ + --replace "(asdf:system-source-directory :trivial-mimes)" '"/bogus-dir"' + # We want to prevent an ASDF lookup at build time since this will + # generally fail — we are not using ASDF after all. + ''; + +in +depot.nix.buildLisp.library { + name = "trivial-mimes"; + + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + ]; + + srcs = [ mime-types ]; +} diff --git a/third_party/lisp/uax-15.nix b/third_party/lisp/uax-15.nix new file mode 100644 index 000000000000..f98c029d3688 --- /dev/null +++ b/third_party/lisp/uax-15.nix @@ -0,0 +1,43 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) runCommand; + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.uax-15; +in +depot.nix.buildLisp.library { + name = "uax-15"; + + deps = with depot.third_party.lisp; [ + split-sequence + cl-ppcre + (bundled "asdf") + ]; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/utilities.lisp" + "${src}/src/trivial-utf-16.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 '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 new file mode 100644 index 000000000000..248296113263 --- /dev/null +++ b/third_party/lisp/unix-opts.nix @@ -0,0 +1,12 @@ +# unix-opts is a portable command line argument parser +{ depot, pkgs, ... }: + + +let src = with pkgs; srcOnly lispPackages.unix-opts; +in depot.nix.buildLisp.library { + name = "unix-opts"; + + srcs = [ + "${src}/unix-opts.lisp" + ]; +} diff --git a/third_party/lisp/usocket-server.nix b/third_party/lisp/usocket-server.nix new file mode 100644 index 000000000000..5d6d04535f0c --- /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 new file mode 100644 index 000000000000..589a3a0cfc92 --- /dev/null +++ b/third_party/lisp/usocket.nix @@ -0,0 +1,46 @@ +# Usocket is a portable socket library +{ depot, pkgs, ... }: + +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") + { + ecl = buildLisp.bundled "sb-bsd-sockets"; + sbcl = buildLisp.bundled "sb-bsd-sockets"; + } + split-sequence + ]; + + srcs = [ + # usocket also reads its version from ASDF, but there's further + # shenanigans happening there that I don't intend to support right + # now. Behold: + (builtins.toFile "usocket.asd" '' + (in-package :asdf) + (defsystem usocket + :version "0.8.3") + '') + ] ++ + # Now for the regularly scheduled programming: + (map (f: src + ("/" + f)) [ + "package.lisp" + "usocket.lisp" + "condition.lisp" + ] ++ [ + { sbcl = "${src}/backend/sbcl.lisp"; } + + # ECL actually has two files, it supports the SBCL backend, + # but usocket also has some ECL specific code + { ecl = "${src}/backend/sbcl.lisp"; } + { ecl = "${src}/backend/ecl.lisp"; } + + # Same for CCL + { ccl = "${src}/backend/openmcl.lisp"; } + { ccl = "${src}/backend/clozure.lisp"; } + ]); +} |