diff options
Diffstat (limited to 'third_party/lisp')
131 files changed, 13744 insertions, 0 deletions
diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS new file mode 100644 index 0000000000..2d7f7e237b --- /dev/null +++ b/third_party/lisp/OWNERS @@ -0,0 +1,5 @@ +# -*- mode: yaml; -*- +inherited: true +owners: + - eta + - grfn diff --git a/third_party/lisp/alexandria.nix b/third_party/lisp/alexandria.nix new file mode 100644 index 0000000000..b522e2d142 --- /dev/null +++ b/third_party/lisp/alexandria.nix @@ -0,0 +1,28 @@ +# Alexandria is one of the foundational Common Lisp libraries that +# pretty much everything depends on. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.alexandria; +in depot.nix.buildLisp.library { + name = "alexandria"; + + srcs = map (f: src + ("/alexandria-1/" + f)) [ + "package.lisp" + "definitions.lisp" + "binding.lisp" + "strings.lisp" + "conditions.lisp" + "symbols.lisp" + "macros.lisp" + "functions.lisp" + "io.lisp" + "hash-tables.lisp" + "control-flow.lisp" + "lists.lisp" + "types.lisp" + "arrays.lisp" + "sequences.lisp" + "numbers.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/anaphora.nix b/third_party/lisp/anaphora.nix new file mode 100644 index 0000000000..c079943e67 --- /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 0000000000..2b45716e47 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitattributes @@ -0,0 +1,2 @@ +.gitignore export-ignore +.gitattributes export-ignore diff --git a/third_party/lisp/asdf-flv/.gitignore b/third_party/lisp/asdf-flv/.gitignore new file mode 100644 index 0000000000..bdf4ad2ae6 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitignore @@ -0,0 +1,3 @@ +sbcl-*/ +cmu-*/ +openmcl-*/ diff --git a/third_party/lisp/asdf-flv/Makefile b/third_party/lisp/asdf-flv/Makefile new file mode 100644 index 0000000000..b4c74feefe --- /dev/null +++ b/third_party/lisp/asdf-flv/Makefile @@ -0,0 +1,77 @@ +### Makefile --- Toplevel directory + +## Copyright (C) 2011, 2015 Didier Verna + +## Author: Didier Verna <didier@didierverna.net> + +## This file is part of ASDF-FLV. + +## Copying and distribution of this file, with or without modification, +## are permitted in any medium without royalty provided the copyright +## notice and this notice are preserved. This file is offered as-is, +## without any warranty. + + +### Commentary: + +## Contents management by FCM version 0.1. + + +### Code: + +PROJECT := asdf-flv +VERSION := 2.1 + +W3DIR := $(HOME)/www/software/lisp/$(PROJECT) + +DIST_NAME := $(PROJECT)-$(VERSION) +TARBALL := $(DIST_NAME).tar.gz +SIGNATURE := $(TARBALL).asc + + +all: + +clean: + -rm *~ + +distclean: clean + -rm *.tar.gz *.tar.gz.asc + +tag: + git tag -a -m 'Version $(VERSION)' 'version-$(VERSION)' + +tar: $(TARBALL) +gpg: $(SIGNATURE) +dist: tar gpg + +install-www: dist + -install -m 644 $(TARBALL) "$(W3DIR)/attic/" + -install -m 644 $(SIGNATURE) "$(W3DIR)/attic/" + echo "\ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz\", \ + contents (\"Dernière version\", \"Latest version\")); ?> \ +| \ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz.asc\", \ + contents (\"Signature GPG\", \"GPG Signature\")); ?>" \ + > "$(W3DIR)/latest.txt" + chmod 644 "$(W3DIR)/latest.txt" + cd "$(W3DIR)" \ + && ln -fs attic/$(TARBALL) latest.tar.gz \ + && ln -fs attic/$(SIGNATURE) latest.tar.gz.asc + +update-version: + perl -pi -e 's/:version ".*"/:version "$(VERSION)"/' \ + net.didierverna.$(PROJECT).asd + +$(TARBALL): + git archive --format=tar --prefix=$(DIST_NAME)/ \ + --worktree-attributes HEAD \ + | gzip -c > $@ + +$(SIGNATURE): $(TARBALL) + gpg -b -a $< + + +.PHONY: all clean distclean tag tar gpg dist install-www update-version + +### Makefile ends here diff --git a/third_party/lisp/asdf-flv/README.md b/third_party/lisp/asdf-flv/README.md new file mode 100644 index 0000000000..7ccdd18881 --- /dev/null +++ b/third_party/lisp/asdf-flv/README.md @@ -0,0 +1,7 @@ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like `*PACKAGE*` and `*READTABLE*` with respect to `LOAD` and +`COMPILE-FILE`: a new dynamic binding is created before processing the file, +so that any modification to the variable essentially becomes file-local. + +In order to make one or several variables file-local, use the macros +`SET-FILE-LOCAL-VARIABLE(S)`. diff --git a/third_party/lisp/asdf-flv/asdf-flv.lisp b/third_party/lisp/asdf-flv/asdf-flv.lisp new file mode 100644 index 0000000000..76c6845b82 --- /dev/null +++ b/third_party/lisp/asdf-flv/asdf-flv.lisp @@ -0,0 +1,64 @@ +;;; asdf-flv.lisp --- Implementation + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :net.didierverna.asdf-flv) + + +(defvar *file-local-variables* () + "List of file-local special variables.") + + +(defun make-variable-file-local (symbol) + "Make special variable named by SYMBOL have a file-local value." + (pushnew symbol *file-local-variables*)) + +(defmacro set-file-local-variable (symbol) + "Set special variable named by SYMBOL as file-local. +SYMBOL need not be quoted." + `(make-variable-file-local ',symbol)) + +(defun make-variables-file-local (&rest symbols) + "Make special variables named by SYMBOLS have a file-local value." + (dolist (symbol symbols) + (pushnew symbol *file-local-variables*))) + +(defmacro set-file-local-variables (&rest symbols) + "Set special variables named by SYMBOLS as file-local. +SYMBOLS need not be quoted." + `(make-variables-file-local ,@(mapcar (lambda (symbol) (list 'quote symbol)) + symbols))) + + +(defmethod asdf:perform :around + ((operation asdf:load-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +(defmethod asdf:perform :around + ((operation asdf:compile-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +;;; asdf-flv.lisp ends here diff --git a/third_party/lisp/asdf-flv/default.nix b/third_party/lisp/asdf-flv/default.nix new file mode 100644 index 0000000000..e8ec4aa8f8 --- /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 0000000000..41202746d0 --- /dev/null +++ b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd @@ -0,0 +1,43 @@ +;;; net.didierverna.asdf-flv.asd --- ASDF system definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(asdf:defsystem :net.didierverna.asdf-flv + :long-name "ASDF File Local Variables" + :description "ASDF extension to provide support for file-local variables." + :long-description "\ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like *PACKAGE* and *READTABLE* with respect to LOAD and +COMPILE-FILE: a new dynamic binding is created before processing the file, so +that any modification to the variable becomes essentially file-local. + +In order to make one or several variables file-local, use the macros +SET-FILE-LOCAL-VARIABLE(S)." + :author "Didier Verna" + :mailto "didier@didierverna.net" + :homepage "http://www.lrde.epita.fr/~didier/software/lisp/misc.php#asdf-flv" + :source-control "https://github.com/didierverna/asdf-flv" + :license "GNU All Permissive" + :version "2.1" + :serial t + :components ((:file "package") + (:file "asdf-flv"))) + +;;; net.didierverna.asdf-flv.asd ends here diff --git a/third_party/lisp/asdf-flv/package.lisp b/third_party/lisp/asdf-flv/package.lisp new file mode 100644 index 0000000000..1d7fb2bab4 --- /dev/null +++ b/third_party/lisp/asdf-flv/package.lisp @@ -0,0 +1,28 @@ +;;; package.lisp --- Package definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :cl-user) + +(defpackage :net.didierverna.asdf-flv + (:use :cl) + (:export :set-file-local-variable :set-file-local-variables)) + +;;; package.lisp ends here diff --git a/third_party/lisp/babel.nix b/third_party/lisp/babel.nix new file mode 100644 index 0000000000..ae7c5dd23d --- /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 0000000000..8a2e099508 --- /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 0000000000..de1d0c2e8e --- /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 0000000000..59e9914ee1 --- /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 0000000000..d3f50bcb1a --- /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 0000000000..0e34015247 --- /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 0000000000..08055a0471 --- /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 0000000000..b51e4d46a7 --- /dev/null +++ b/third_party/lisp/cl-colors.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-colors; +in depot.nix.buildLisp.library { + name = "cl-colors"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.let-plus + ]; + srcs = [ + "${src}/package.lisp" + "${src}/colors.lisp" + "${src}/colornames.lisp" + "${src}/hexcolors.lisp" + ]; +} diff --git a/third_party/lisp/cl-colors2.nix b/third_party/lisp/cl-colors2.nix new file mode 100644 index 0000000000..34201bc2fa --- /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 0000000000..e53cb2dfce --- /dev/null +++ b/third_party/lisp/cl-date-time-parser.nix @@ -0,0 +1,21 @@ +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "cl-date-time-parser"; + + srcs = [ + (pkgs.fetchurl { + url = "https://raw.githubusercontent.com/tkych/cl-date-time-parser/00d6fc70b599f460fdf13cf0cf7e6bf843312410/date-time-parser.lisp"; + sha256 = "0zrkv1q3sx5ksijxhw45ixf1hy5b9biii6i6v41h12q6pbkfqz69"; + }) + ]; + + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.anaphora + depot.third_party.lisp.split-sequence + depot.third_party.lisp.cl-ppcre + depot.third_party.lisp.local-time + depot.third_party.lisp.parse-float + ]; +} diff --git a/third_party/lisp/cl-fad.nix b/third_party/lisp/cl-fad.nix new file mode 100644 index 0000000000..9350abe2e3 --- /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 0000000000..0230f274af --- /dev/null +++ b/third_party/lisp/cl-json.nix @@ -0,0 +1,29 @@ +# JSON encoder & decoder +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + + src = pkgs.fetchFromGitHub { + owner = "hankhero"; + repo = "cl-json"; + rev = "6dfebb9540bfc3cc33582d0c03c9ec27cb913e79"; + sha256 = "0fx3m3x3s5ji950yzpazz4s0img3l6b3d6l3jrfjv0lr702496lh"; + }; +in +buildLisp.library { + name = "cl-json"; + deps = [ (buildLisp.bundled "asdf") ]; + + srcs = [ "${src}/cl-json.asd" ] ++ + (map (f: src + ("/src/" + f)) [ + "package.lisp" + "common.lisp" + "objects.lisp" + "camel-case.lisp" + "decoder.lisp" + "encoder.lisp" + "utils.lisp" + "json-rpc.lisp" + ]); +} diff --git a/third_party/lisp/cl-plus-ssl.nix b/third_party/lisp/cl-plus-ssl.nix new file mode 100644 index 0000000000..dc0a95944f --- /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 0000000000..561e306191 --- /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 0000000000..188cbc686d --- /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 0000000000..7ab9bea59f --- /dev/null +++ b/third_party/lisp/cl-smtp.nix @@ -0,0 +1,24 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-smtp; +in depot.nix.buildLisp.library { + name = "cl-smtp"; + deps = with depot.third_party.lisp; [ + usocket + trivial-gray-streams + flexi-streams + cl-base64 + cl-plus-ssl + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "attachments.lisp" + "cl-smtp.lisp" + "mime-types.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/cl-unicode.nix b/third_party/lisp/cl-unicode.nix new file mode 100644 index 0000000000..815d99c2dc --- /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 0000000000..601b09f118 --- /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 0000000000..b40d5d0601 --- /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 0000000000..145b9cfd43 --- /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 0000000000..7f7f79f855 --- /dev/null +++ b/third_party/lisp/closure-common.nix @@ -0,0 +1,36 @@ +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.closure-common; + getSrcs = builtins.map (p: "${src}/${p}"); +in +depot.nix.buildLisp.library { + name = "closure-common"; + + # closure-common.asd surpresses some warnings otherwise breaking + # compilation. Feature macros across implementations: + # + # ECL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # CCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # SBCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # + # Since all implementations agree, the alternative files aren't encoded here. + srcs = getSrcs [ + "closure-common.asd" + "package.lisp" + "definline.lisp" + "characters.lisp" #+rune-is-character + "syntax.lisp" + "encodings.lisp" #-x&y-streams-are-stream + "encodings-data.lisp" #-x&y-streams-are-stream + "xstream.lisp" #-x&y-streams-are-stream + "ystream.lisp" #-x&y-streams-are-stream + "hax.lisp" + ]; + + deps = [ + (depot.nix.buildLisp.bundled "asdf") + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.babel #+rune-is-character + ]; +} diff --git a/third_party/lisp/closure-html/default.nix b/third_party/lisp/closure-html/default.nix new file mode 100644 index 0000000000..1886ea2ec9 --- /dev/null +++ b/third_party/lisp/closure-html/default.nix @@ -0,0 +1,65 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + name = "closure-html-source"; + src = pkgs.lispPackages.closure-html.src; + + patches = [ + # delete unexported and unused double defun in sgml-dtd.lisp + # which reference undefined CL-USER:*HTML-DTD* (!) which + # unlike CLOSURE-HTML:*HTML-DTD* is not involved in the + # packages operation. + ./no-double-defun.patch + # Patches html-parser.lisp to look for the distributed + # dtd files and catalog in this source derivations out + # path in the nix store instead of the same directory + # relatively to the (built) system. + ./dtds-from-store.patch + ]; + + postPatch = '' + # Inject file which defines CLOSURE-HTML:*HTML-DTD* + # early in the package's build since SBCL otherwise + # fails due to the undefined variable. Need to inject + # this via postPatch since using a nix file results + # in failure to look up the file's true name which + # is done for … reasons, apparently. + cat > src/define-html-dtd.lisp << EOF + (in-package :closure-html) + (defvar *html-dtd*) + EOF + + # Substitute reference to @out@ of this source + # directory in this patched file. + substituteAllInPlace src/parse/html-parser.lisp + ''; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); +in + +depot.nix.buildLisp.library { + name = "closure-html"; + + srcs = getSrcs [ + "src/defpack.lisp" + "src/define-html-dtd.lisp" + "src/glisp/util.lisp" + "src/util/clex.lisp" + "src/util/lalr.lisp" + "src/net/mime.lisp" + "src/parse/pt.lisp" + "src/parse/sgml-dtd.lisp" + "src/parse/sgml-parse.lisp" + "src/parse/html-parser.lisp" + "src/parse/lhtml.lisp" + "src/parse/unparse.lisp" + "src/parse/documentation.lisp" + ]; + + deps = [ + depot.third_party.lisp.flexi-streams + depot.third_party.lisp.closure-common + ]; +} diff --git a/third_party/lisp/closure-html/dtds-from-store.patch b/third_party/lisp/closure-html/dtds-from-store.patch new file mode 100644 index 0000000000..a9ffd8085e --- /dev/null +++ b/third_party/lisp/closure-html/dtds-from-store.patch @@ -0,0 +1,16 @@ +diff --git a/src/parse/html-parser.lisp b/src/parse/html-parser.lisp +index 4e45b81..5025a26 100644 +--- a/src/parse/html-parser.lisp ++++ b/src/parse/html-parser.lisp +@@ -36,10 +36,7 @@ + (make-pathname + :name nil + :type nil +- :defaults (merge-pathnames +- "resources/" +- (asdf:component-relative-pathname +- (asdf:find-system :closure-html)))))) ++ :defaults "@out@/resources/"))) + (loop + :for (name . filename) + :in '(("-//W3O//DTD W3 HTML 3.0//EN" . "dtd/HTML-3.0") diff --git a/third_party/lisp/closure-html/no-double-defun.patch b/third_party/lisp/closure-html/no-double-defun.patch new file mode 100644 index 0000000000..ce7fb33abf --- /dev/null +++ b/third_party/lisp/closure-html/no-double-defun.patch @@ -0,0 +1,78 @@ +diff --git a/src/parse/sgml-dtd.lisp b/src/parse/sgml-dtd.lisp +index de774c0..dbee852 100644 +--- a/src/parse/sgml-dtd.lisp ++++ b/src/parse/sgml-dtd.lisp +@@ -624,73 +624,6 @@ + (return)))) + classes)) + +-;;;; ---------------------------------------------------------------------------------------------------- +-;;;; Compiled DTDs +-;;;; +- +-;; Since parsing and 'compiling' DTDs is slow, I'll provide for a way +-;; to (un)dump compiled DTD to stream. +- +-(defun dump-dtd (dtd sink) +- (let ((*print-pretty* nil) +- (*print-readably* t) +- (*print-circle* t)) +- (princ "#." sink) +- (prin1 +- `(MAKE-DTD :NAME ',(dtd-name dtd) +- :ELEMENTS (LET ((R (MAKE-HASH-TABLE :TEST #'EQ))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-elements dtd)) +- q)) +- R) +- :ENTITIES ',(dtd-entities dtd) +- :RESOLVE-INFO (LET ((R (MAKE-HASH-TABLE :TEST #'EQUAL))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-resolve-info dtd)) +- q)) +- R) +- ;; XXX surclusion-cache fehlt +- ) +- sink))) +- +-;;XXX +-(defun save-html-dtd () +- (with-open-file (sink "html-dtd.lisp" :direction :output :if-exists :new-version) +- (print `(in-package :sgml) sink) +- (let ((*package* (find-package :sgml))) +- (princ "(SETQ " sink) +- (prin1 'cl-user::*html-dtd* sink) +- (princ " '" sink) +- (dump-dtd cl-user::*html-dtd* sink) +- (princ ")" sink)))) +- +-;;; -------------------------------------------------------------------------------- +-;;; dumping DTDs +- +- +-(defun dump-dtd (dtd filename) +- (let ((*foo* dtd)) +- (declare (special *foo*)) +- (with-open-file (sink (merge-pathnames filename "*.lisp") +- :direction :output +- :if-exists :new-version) +- (format sink "(in-package :sgml)(locally (declare (special *foo*))(setq *foo* '#.*foo*))")) +- (compile-file (merge-pathnames filename "*.lisp")))) +- +-(defun undump-dtd (filename) +- (let (*foo*) +- (declare (special *foo*)) +- (load (compile-file-pathname (merge-pathnames filename "*.lisp")) +- :verbose nil +- :print nil) +- *foo*)) +- + (defmethod make-load-form ((self dtd) &optional env) + (declare (ignore env)) + `(make-dtd :name ',(dtd-name self) diff --git a/third_party/lisp/defclass-std.nix b/third_party/lisp/defclass-std.nix new file mode 100644 index 0000000000..c31ddb3c5b --- /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 0000000000..607f438d7e --- /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 0000000000..5caf8261fa --- /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 0000000000..500e980a81 --- /dev/null +++ b/third_party/lisp/fiveam.nix @@ -0,0 +1,29 @@ +# FiveAM is a Common Lisp testing framework. +# +# Imported from https://github.com/sionescu/fiveam.git + +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.fiveam; +in depot.nix.buildLisp.library { + name = "fiveam"; + + deps = with depot.third_party.lisp; [ + alexandria + asdf-flv + trivial-backtrace + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "utils.lisp" + "check.lisp" + "fixture.lisp" + "classes.lisp" + "random.lisp" + "test.lisp" + "explain.lisp" + "suite.lisp" + "run.lisp" + ]; +} diff --git a/third_party/lisp/flexi-streams.nix b/third_party/lisp/flexi-streams.nix new file mode 100644 index 0000000000..a6a06d4ad0 --- /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 0000000000..a3d27a09b6 --- /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 0000000000..e2480cd349 --- /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 0000000000..324c5da265 --- /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 0000000000..b7d60265ac --- /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 0000000000..00f66c1fe3 --- /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 0000000000..bd7f31dfa0 --- /dev/null +++ b/third_party/lisp/let-plus.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.let-plus; +in depot.nix.buildLisp.library { + name = "let-plus"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.anaphora + ]; + srcs = [ + "${src}/package.lisp" + "${src}/let-plus.lisp" + "${src}/extensions.lisp" + ]; +} diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix new file mode 100644 index 0000000000..8deba4546f --- /dev/null +++ b/third_party/lisp/lisp-binary.nix @@ -0,0 +1,37 @@ +# A library to easily read and write complex binary formats. +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "j3pic"; + repo = "lisp-binary"; + rev = "052df578900dea59bf951e0a6749281fa73432e4"; + sha256 = "1i1s5g01aimfq6lndcl1pnw7ly5hdh0wmjp2dj9cjjwbkz9lnwcf"; + }; +in +depot.nix.buildLisp.library { + name = "lisp-binary"; + + deps = with depot.third_party.lisp; [ + cffi + quasiquote_2 + moptilities + flexi-streams + closer-mop + ]; + + srcs = map (f: src + ("/" + f)) [ + "utils.lisp" + "integer.lisp" + "float.lisp" + "simple-bit-stream.lisp" + "reverse-stream.lisp" + "binary-1.lisp" + "binary-2.lisp" + "types.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix new file mode 100644 index 0000000000..1358408d38 --- /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 0000000000..73a1664a01 --- /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 0000000000..8c3e255f16 --- /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 0000000000..fc046d0895 --- /dev/null +++ b/third_party/lisp/metabang-bind.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +let + getSrcs = builtins.map (p: "${pkgs.srcOnly pkgs.lispPackages.metabang-bind}/${p}"); +in + +depot.nix.buildLisp.library { + name = "metabang-bind"; + + srcs = getSrcs [ + "dev/packages.lisp" + "dev/macros.lisp" + "dev/bind.lisp" + "dev/binding-forms.lisp" + ]; +} diff --git a/third_party/lisp/mime4cl/.skip-subtree b/third_party/lisp/mime4cl/.skip-subtree new file mode 100644 index 0000000000..5051f60d6b --- /dev/null +++ b/third_party/lisp/mime4cl/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS new file mode 100644 index 0000000000..f16dd105d7 --- /dev/null +++ b/third_party/lisp/mime4cl/OWNERS @@ -0,0 +1,3 @@ +inherited: true +owners: + - sterni diff --git a/third_party/lisp/mime4cl/README b/third_party/lisp/mime4cl/README new file mode 100644 index 0000000000..73f0efbda9 --- /dev/null +++ b/third_party/lisp/mime4cl/README @@ -0,0 +1,7 @@ +MIME4CL is a Common Lisp library for dealing with MIME messages. +It has originally been written by Walter C. Pelissero and vendored +into depot as upstream has become inactive and provides no repo +of any kind. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#mime4cl +Vendored Tarball: http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp new file mode 100644 index 0000000000..944156916c --- /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 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) + (be string (with-output-to-string (out) + (write-char first-character out) + (loop + for c = (read-char (cursor-stream cursor) nil) + while (and c (atom-component-p c)) + do (write-char c out) + finally (when c + (unread-char c (cursor-stream cursor))))) + (make-token :type 'atext + :value string + :position (incf (cursor-position cursor))))) + +(defmethod read-next-tokens ((cursor cursor)) + (flet ((make-keyword (c) + (make-token :type 'keyword + :value (string c) + :position (incf (cursor-position cursor))))) + (be in (cursor-stream cursor) + (loop + for c = (read-char in nil) + while c + unless (whitespace-p c) + return (list + (cond ((char= #\( c) + (read-comment cursor)) + ((char= #\" c) + (read-string cursor)) + ((char= #\[ c) + (read-domain-literal cursor)) + ((find c "@.<>:;,") + (make-keyword c)) + (t + ;; anything else is considered a text atom even + ;; though it's just a single character + (read-atext c cursor)))))))) + +(defun analyse-string (string) + "Return the list of tokens produced by a lexical analysis of +STRING. These are the tokens that would be seen by the parser." + (with-input-from-string (stream string) + (be cursor (make-cursor :stream stream) + (loop + for tokens = (read-next-tokens cursor) + until (endp tokens) + append tokens)))) + +(defun mailboxes-only (list-of-mailboxes-and-groups) + "Return a flat list of MAILBOX-ADDRESSes from +LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned +by PARSE-ADDRESSES. This turns out to be useful when your +program is not interested in mailbox groups and expects the user +addresses only." + (mapcan #'(lambda (mbx) + (if (typep mbx 'mailbox-group) + (mbxg-mailboxes mbx) + (list mbx))) + list-of-mailboxes-and-groups)) + +(defun parse-addresses (string &key no-groups) + "Parse STRING and return a list of MAILBOX-ADDRESSes or +MAILBOX-GROUPs. If STRING is unparsable return NIL. If +NO-GROUPS is true, return a flat list of mailboxes throwing away +the group containers, if any." + (be grammar (force define-grammar) + (with-input-from-string (stream string) + (be* cursor (make-cursor :stream stream) + mailboxes (ignore-errors ; ignore parsing errors + (parse grammar 'address-list cursor)) + (if no-groups + (mailboxes-only mailboxes) + mailboxes))))) + +(defun debug-addresses (string) + "More or less like PARSE-ADDRESSES, but don't ignore parsing errors." + (be grammar (force define-grammar) + (with-input-from-string (stream string) + (be cursor (make-cursor :stream stream) + (parse grammar 'address-list cursor))))) + diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix new file mode 100644 index 0000000000..9d3d6253f4 --- /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.babel + depot.third_party.lisp.sclf + depot.third_party.lisp.npg + depot.third_party.lisp.trivial-gray-streams + ]; + + srcs = [ + ./package.lisp + ./endec.lisp + ./streams.lisp + ./mime.lisp + ./address.lisp + ]; + + tests = { + name = "mime4cl-tests"; + + srcs = [ + ./test/rt.lisp + ./test/package.lisp + (pkgs.writeText "nix-samples.lisp" '' + (in-package :mime4cl-tests) + + ;; missing from the tarball completely + (defvar *samples-directory* (pathname "/this/does/not/exist")) + ;; override auto discovery which doesn't work in store + (defvar *sample1-file* (pathname "${./test/sample1.msg}")) + '') + ./test/endec.lisp + ./test/address.lisp + ./test/mime.lisp + ]; + + expression = "(rtest:do-tests)"; + }; + + # limited by sclf + brokenOn = [ + "ccl" + "ecl" + ]; +} diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp new file mode 100644 index 0000000000..020c212e5e --- /dev/null +++ b/third_party/lisp/mime4cl/endec.lisp @@ -0,0 +1,697 @@ +;;; endec.lisp --- encoder/decoder functions + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + + +(in-package :mime4cl) + + +;; Thank you SBCL for rendering constants totally useless! +(defparameter +base64-encode-table+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") + +(defparameter +base64-decode-table+ + (let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65))) + (dotimes (i 64) + (setf (aref da (char-code (char +base64-encode-table+ i))) i)) + da)) + +(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+) + (type simple-string +base64-encode-table+)) + +(defvar *base64-line-length* 76 + "Maximum length of the encoded base64 line. NIL means it can +be of unlimited length \(no line breaks will be done by the +encoding function).") + +(defvar *quoted-printable-line-length* 72 + "Maximum length of the encoded quoted printable line. NIL +means it can be of unlimited length \(no line breaks will be done +by the encoding function).") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass decoder () + ((input-function :initarg :input-function + :reader decoder-input-function + :type function + :documentation + "Function is called repeatedly by the decoder methods to get the next character. +It should return a character os NIL (indicating EOF).")) + (:documentation + "Abstract base class for decoders.")) + +(defclass parsing-decoder (decoder) + ((parser-errors :initform nil + :initarg :parser-errors + :reader decoder-parser-errors + :type boolean)) + (:documentation + "Abstract base class for decoders that do parsing.")) + +(defclass encoder () + ((output-function :initarg :output-function + :reader encoder-output-function + :type function + :documentation + "Function is called repeatedly by the encoder methods to output a character. +It should expect a character as its only argument.")) + (:documentation + "Abstract base class for encoders.")) + +(defclass line-encoder (encoder) + ((column :initform 0 + :type fixnum) + (line-length :initarg :line-length + :initform nil + :reader encoder-line-length + :type (or fixnum null))) + (:documentation + "Abstract base class for line encoders.")) + +(defclass 8bit-decoder (decoder) + () + (:documentation + "Class for decoders that do nothing.")) + +(defclass 8bit-encoder (encoder) + () + (:documentation + "Class for encoders that do nothing.")) + +(defclass 7bit-decoder (decoder) + () + (:documentation + "Class for decoders that do nothing.")) + +(defclass 7bit-encoder (encoder) + () + (:documentation + "Class for encoders that do nothing.")) + +(defclass byte-decoder (decoder) + () + (:documentation + "Class for decoders that turns chars to bytes.")) + +(defclass byte-encoder (encoder) + () + (:documentation + "Class for encoders that turns bytes to chars.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric encoder-write-byte (encoder byte)) +(defgeneric encoder-finish-output (encoder)) +(defgeneric decoder-read-byte (decoder)) + +(defmethod encoder-finish-output ((encoder encoder)) + (values)) + +(defmethod encoder-write-byte ((encoder 8bit-encoder) byte) + (funcall (slot-value encoder 'output-function) + (code-char byte)) + (values)) + +(defmethod decoder-read-byte ((decoder 8bit-decoder)) + (awhen (funcall (slot-value decoder 'input-function)) + (char-code it))) + +(defmethod encoder-write-byte ((encoder 7bit-encoder) byte) + (funcall (slot-value encoder 'output-function) + (code-char (logand #x7F byte))) + (values)) + +(defmethod decoder-read-byte ((decoder 7bit-decoder)) + (awhen (funcall (slot-value decoder 'input-function)) + (logand #x7F (char-code it)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence))) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type fixnum start end) + (type vector sequence)) + (loop + for i fixnum from start below end + for byte = (decoder-read-byte decoder) + while byte + do (setf (aref sequence i) byte) + finally (return i))) + +(defun decoder-read-line (decoder) + (with-output-to-string (str) + (loop + for byte = (decoder-read-byte decoder) + unless byte + do (return-from decoder-read-line nil) + do (be c (code-char byte) + (cond ((char= c #\return) + ;; skip the newline + (decoder-read-byte decoder) + (return nil)) + ((char= c #\newline) + ;; the #\return was missing + (return nil)) + (t (write-char c str))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline parse-hex)) +(defun parse-hex (c1 c2) + "Parse two characters as hexadecimal and return their combined +value." + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type character c1 c2)) + (flet ((digit-value (char) + (or (position char "0123456789ABCDEF") + (return-from parse-hex nil)))) + (+ (* 16 (digit-value c1)) + (digit-value c2)))) + +(defclass quoted-printable-decoder (parsing-decoder) + ((saved-bytes :initform (make-queue)))) + +(defmethod decoder-read-byte ((decoder quoted-printable-decoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (input-function saved-bytes parser-errors) decoder + (declare (type function input-function)) + (labels ((saveb (b) + (queue-append saved-bytes b) + (values)) + (save (c) + (saveb (char-code c))) + (push-next () + (be c (funcall input-function) + (declare (type (or null character) c)) + (cond ((not c)) + ((or (char= c #\space) + (char= c #\tab)) + (save c) + (push-next)) + ((char= c #\=) + (be c1 (funcall input-function) + (cond ((not c1) + (save #\=)) + ((char= c1 #\return) + ;; soft line break: skip the next + ;; character which we assume to be a + ;; newline (pity if it isn't) + (funcall input-function) + (push-next)) + ((char= c1 #\newline) + ;; soft line break: the #\return is + ;; missing, but we are tolerant + (push-next)) + (t + ;; hexadecimal sequence: get the 2nd digit + (be c2 (funcall input-function) + (if c2 + (aif (parse-hex c1 c2) + (saveb it) + (if parser-errors + (error "invalid hex sequence ~A~A" c1 c2) + (progn + (save #\=) + (save c1) + (save c2)))) + (progn + (save c) + (save c1)))))))) + (t + (save c)))))) + (or (queue-pop saved-bytes) + (progn + (push-next) + (queue-pop saved-bytes)))))) + +(defmacro make-encoder-loop (encoder-class input-form output-form) + (with-gensyms (encoder byte) + `(loop + with ,encoder = (make-instance ',encoder-class + :output-function #'(lambda (char) ,output-form)) + for ,byte = ,input-form + while ,byte + do (encoder-write-byte ,encoder ,byte) + finally (encoder-finish-output ,encoder)))) + +(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors) + (with-gensyms (decoder) + `(loop + with ,decoder = (make-instance ',decoder-class + :input-function #'(lambda () ,input-form) + :parser-errors ,parser-errors) + for byte = (decoder-read-byte ,decoder) + while byte + do ,output-form))) + +(defun decode-quoted-printable-stream (in out &key parser-errors) + "Read from stream IN a quoted printable text and write to +binary output OUT the decoded stream of bytes." + (make-decoder-loop quoted-printable-decoder + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) + +(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors) + "Decode the character stream STREAM and return a sequence of bytes." + (with-gensyms (output-sequence) + `(be ,output-sequence (make-array 0 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t) + (make-decoder-loop ,decoder-class ,input-form + (vector-push-extend byte ,output-sequence) + :parser-errors ,parser-errors) + ,output-sequence))) + +(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors) + "Read from STREAM a quoted printable text and return a vector of +bytes." + (make-stream-to-sequence-decoder quoted-printable-decoder + (read-char stream nil) + :parser-errors parser-errors)) + +(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors) + "Decode STRING as quoted printable sequence of characters and +return a decoded sequence of bytes." + (with-input-from-string (in string :start start :end end) + (decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors))) + +(defclass quoted-printable-encoder (line-encoder) + ((line-length :initform *quoted-printable-line-length* + :type (or fixnum null)) + (pending-space :initform nil + :type boolean))) + +(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type (unsigned-byte 8) byte)) + (with-slots (output-function column pending-space line-length) encoder + (declare (type function output-function) + (type fixnum column) + (type (or fixnum null) line-length) + (type boolean pending-space)) + (labels ((out (c) + (funcall output-function c) + (values)) + (outs (str) + (declare (type simple-string str)) + (loop + for c across str + do (out c)) + (values)) + (out2hex (x) + (declare (type fixnum x)) + (multiple-value-bind (a b) (truncate x 16) + (out (digit-char a 16)) + (out (digit-char b 16))))) + (cond ((= byte #.(char-code #\newline)) + (when pending-space + (outs "=20") + (setf pending-space nil)) + (out #\newline) + (setf column 0)) + ((= byte #.(char-code #\space)) + (if pending-space + (progn + (out #\space) + (f++ column)) + (setf pending-space t))) + (t + (when pending-space + (out #\space) + (f++ column) + (setf pending-space nil)) + (cond ((or (< byte 32) + (= byte #.(char-code #\=)) + (> byte 126)) + (out #\=) + (out2hex byte) + (f++ column 3)) + (t + (out (code-char byte)) + (f++ column))))) + (when (and line-length + (>= column line-length)) + ;; soft line break + (outs #.(coerce '(#\= #\newline) 'string)) + (setf column 0))))) + +(defmethod encoder-finish-output ((encoder quoted-printable-encoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (pending-space output-function) encoder + (declare (type boolean pending-space) + (type function output-function)) + (when pending-space + (flet ((outs (s) + (declare (type simple-string s)) + (loop + for c across s + do (funcall output-function c)))) + (setf pending-space nil) + (outs "=20"))))) + +(defun encode-quoted-printable-stream (in out) + "Read from IN a stream of bytes and write to OUT a stream of +characters quoted printables encoded." + (make-encoder-loop quoted-printable-encoder + (read-byte in nil) + (write-char char out))) + +(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE and write to STREAM a +quoted printable sequence of characters." + (be i start + (make-encoder-loop quoted-printable-encoder + (when (< i end) + (prog1 (elt sequence i) + (f++ i))) + (write-char char stream)))) + +(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE into a quoted printable +string and return it." + (with-output-to-string (out) + (encode-quoted-printable-sequence-to-stream sequence out :start start :end end))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass base64-encoder (line-encoder) + ((line-length :initform *base64-line-length*) + (bitstore :initform 0 + :type fixnum) + (bytecount :initform 0 + :type fixnum)) + (:documentation + "Class for Base64 encoder output streams.")) + + +(eval-when (:load-toplevel :compile-toplevel) + (unless (> most-positive-fixnum (expt 2 (* 8 3))))) + +(macrolet ((with-encoder (encoder &body forms) + `(with-slots (bitstore line-length column bytecount output-function) ,encoder + (declare (type fixnum column) + (type fixnum bitstore bytecount) + (type (or fixnum null) line-length) + (type function output-function)) + (labels ((emitr (i b) + (declare (type fixnum i b)) + (unless (zerop i) + (emitr (1- i) (ash b -6))) + (emitc + (char +base64-encode-table+ (logand b #x3F))) + (values)) + (out (c) + (funcall output-function c)) + (eol () + (progn + (out #\return) + (out #\newline))) + (emitc (char) + (out char) + (f++ column) + (when (and line-length + (>= column line-length)) + (setf column 0) + (eol)))) + (declare (inline out eol emitc) + (ignorable (function emitr) (function out) (function eol) (function emitc))) + ,@forms)))) + ;; For this function to work correctly, the FIXNUM must be at least + ;; 24 bits. + (defmethod encoder-write-byte ((encoder base64-encoder) byte) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type (unsigned-byte 8) byte)) + (with-encoder encoder + (setf bitstore (logior byte (the fixnum (ash bitstore 8)))) + (f++ bytecount) + (when (= 3 bytecount) + (emitr 3 bitstore) + (setf bitstore 0 + bytecount 0))) + (values)) + + (defmethod encoder-finish-output ((encoder base64-encoder)) + (with-encoder encoder + (unless (zerop bytecount) + (multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6) + (setf bitstore (ash bitstore (- 6 rest))) + (emitr saved6 bitstore) + (dotimes (x (- 3 saved6)) + (emitc #\=)))) + (when (and line-length + (not (zerop column))) + (eol))) + (values))) + +(defun encode-base64-stream (in out) + "Read a byte stream from IN and write to OUT the encoded Base64 +character stream." + (make-encoder-loop base64-encoder (read-byte in nil) + (write-char char out))) + +(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE and write to STREAM the +Base64 character sequence." + (be i start + (make-encoder-loop base64-encoder + (when (< i end) + (prog1 (elt sequence i) + (incf i))) + (write-char char stream)))) + +(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE into a Base64 string and +return it." + (with-output-to-string (out) + (encode-base64-sequence-to-stream sequence out :start start :end end))) + +(defclass base64-decoder (parsing-decoder) + ((bitstore :initform 0 + :type fixnum) + (bytecount :initform 0 :type fixnum)) + (:documentation + "Class for Base64 decoder input streams.")) + +(defmethod decoder-read-byte ((decoder base64-decoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (bitstore bytecount input-function) decoder + (declare (type fixnum bitstore bytecount) + (type function input-function)) + (labels ((in6 () + (loop + for c = (funcall input-function) + when (or (not c) (char= #\= c)) + do (return-from decoder-read-byte nil) + do (be sextet (aref +base64-decode-table+ (char-code c)) + (unless (= sextet 65) ; ignore unrecognised characters + (return sextet))))) + (push6 (sextet) + (declare (type fixnum sextet)) + (setf bitstore + (logior sextet (the fixnum (ash bitstore 6)))))) + (case bytecount + (0 + (setf bitstore (in6)) + (push6 (in6)) + (setf bytecount 1) + (ash bitstore -4)) + (1 + (push6 (in6)) + (setf bytecount 2) + (logand #xFF (ash bitstore -2))) + (2 + (push6 (in6)) + (setf bytecount 0) + (logand #xFF bitstore)))))) + +(defun decode-base64-stream (in out &key parser-errors) + "Read from IN a stream of characters Base64 encoded and write +to OUT a stream of decoded bytes." + (make-decoder-loop base64-decoder + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) + +(defun decode-base64-stream-to-sequence (stream &key parser-errors) + (make-stream-to-sequence-decoder base64-decoder + (read-char stream nil) + :parser-errors parser-errors)) + +(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors) + (with-input-from-string (in string :start start :end end) + (decode-base64-stream-to-sequence in :parser-errors parser-errors))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun dump-stream-binary (in out) + "Write content of IN character stream to OUT binary stream." + (loop + for c = (read-char in nil) + while c + do (write-byte (char-code c) out))) + +(defun decode-stream (in out encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-stream in out + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-stream in out + :parser-errors parser-errors-p)) + (otherwise + (dump-stream-binary in out)))) + +(defun decode-string (string encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-string string + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-string string + :parser-errors parser-errors-p)) + (otherwise + (map '(vector (unsigned-byte 8)) #'char-code string)))) + +(defun decode-stream-to-sequence (stream encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-stream-to-sequence stream + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-stream-to-sequence stream + :parser-errors parser-errors-p)) + (otherwise + (loop + with output-sequence = (make-array 0 :fill-pointer 0 + :element-type '(unsigned-byte 8) + :adjustable t) + for c = (read-char stream nil) + while c + do (vector-push-extend (char-code c) output-sequence) + finally (return output-sequence))))) + +(defun encode-stream (in out encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-stream in out)) + (:base64 + (encode-base64-stream in out)) + (otherwise + (loop + for byte = (read-byte in nil) + while byte + do (write-char (code-char byte) out))))) + +(defun encode-sequence-to-stream (sequence out encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-sequence-to-stream sequence out)) + (:base64 + (encode-base64-sequence-to-stream sequence out)) + (otherwise + (loop + for byte across sequence + do (write-char (code-char byte) out))))) + +(defun encode-sequence (sequence encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-sequence sequence)) + (:base64 + (encode-base64-sequence sequence)) + (otherwise + (map 'string #'code-char sequence)))) + +;; This is similar to decode-quoted-printable-string but #\_ is used +;; instead of space +(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string))) + "Decode a string encoded according to the quoted printable +method of RFC2047 and return a sequence of bytes." + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type simple-string string)) + (loop + with output-sequence = (make-array (length string) + :element-type '(unsigned-byte 8) + :fill-pointer 0) + for i fixnum from start by 1 below end + for c = (char string i) + do (case c + (#\= + (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i))) + ;; the char code was malformed + #.(char-code #\?)) + output-sequence) + (f++ i 2)) + (#\_ (vector-push-extend #.(char-code #\space) output-sequence)) + (otherwise + (vector-push-extend (char-code c) output-sequence))) + finally (return output-sequence))) + +(defun decode-RFC2047-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" (decode-base64-string string :start start :end end)) + (t string))) + +(defun parse-RFC2047-text (text) + "Parse the string TEXT according to RFC2047 rules and return a list +of pairs and strings. The strings are the bits interposed between the +actually encoded text. The pairs are composed of: a decoded byte +sequence, a charset string indicating the original coding." + (loop + with result = '() + with previous-end = 0 + for start = (search "=?" text :start2 previous-end) + while start + for first-? = (position #\? text :start (+ 2 start)) + while first-? + for second-? = (position #\? text :start (1+ first-?)) + while second-? + for end = (search "?=" text :start2 (1+ second-?)) + while end + do (let ((charset (string-upcase (subseq text (+ 2 start) first-?))) + (encoding (subseq text (1+ first-?) second-?))) + (unless (= previous-end start) + (push (subseq text previous-end start) + result)) + (setf previous-end (+ end 2)) + (push (cons (decode-RFC2047-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 babel, otherwise signal an error." + (flet ((decode-part (part) + (etypecase part + (cons (babel:octets-to-string + (car part) + :encoding (babel-encodings:get-character-encoding + (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/mime.lisp b/third_party/lisp/mime4cl/mime.lisp new file mode 100644 index 0000000000..5639aab236 --- /dev/null +++ b/third_party/lisp/mime4cl/mime.lisp @@ -0,0 +1,1075 @@ +;;; mime4cl.lisp --- MIME primitives for Common Lisp + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl) + +(defclass mime-part () + ((subtype + :type (or string null) + :initarg :subtype + :accessor mime-subtype + ;; some mime types don't require a subtype + :initform nil) + (type-parameters + :type list + :initarg :type-parameters + :initform '() + :accessor mime-type-parameters) + (version + :type (or string null) + :initarg :mime-version + :initform "1.0" + :accessor mime-version) + (id + :initform nil + :initarg :id + :reader mime-id) + (description + :initform nil + :initarg :description + :accessor mime-description) + (encoding + :initform :7bit + :initarg :encoding + :reader mime-encoding + :documentation + "It's supposed to be either: + :7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a + X-token or an ietf-token (whatever that means).") + (disposition + :type (or string null) + :initarg :disposition + :initform nil + :accessor mime-disposition) + (disposition-parameters + :type list + :initarg :disposition-parameters + :initform '() + :accessor mime-disposition-parameters)) + (:documentation + "Abstract base class for all types of MIME parts.")) + +(defclass mime-bodily-part (mime-part) + ((body + :initarg :body + :accessor mime-body)) + (:documentation + "Abstract base class for MIME parts with a body.")) + +(defclass mime-unknown-part (mime-bodily-part) + ((type + :initarg :type + :reader mime-type + :documentation + "The original type string from the MIME header.")) + (:documentation + "MIME part unknown to this library. Accepted but not handled.")) + +(defclass mime-text (mime-bodily-part) ()) + +;; This turns out to be handy when making methods specialised +;; non-textual attachments. +(defclass mime-binary (mime-bodily-part) ()) + +(defclass mime-image (mime-binary) ()) + +(defclass mime-audio (mime-binary) ()) + +(defclass mime-video (mime-binary) ()) + +(defclass mime-application (mime-binary) ()) + +(defclass mime-multipart (mime-part) + ((parts :initarg :parts + :accessor mime-parts))) + +(defclass mime-message (mime-part) + ((headers :initarg :headers + :initform '() + :type list + :accessor mime-message-headers) + (real-message :initarg :body + :accessor mime-body))) + +(defun mime-part-p (object) + (typep object 'mime-part)) + +(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys) + (call-next-method) + ;; The initialization argument of the PARTS slot of a mime-multipart + ;; is expected to be a list of mime-parts. Thus, we implicitly + ;; create the mime parts using the arguments found in this list. + (with-slots (parts) part + (when (slot-boundp part 'parts) + (setf parts + (mapcar #'(lambda (subpart) + (if (mime-part-p subpart) + subpart + (apply #'make-instance subpart))) + parts))))) + +(defmethod initialize-instance ((part mime-message) &key &allow-other-keys) + (call-next-method) + ;; Allow a list of mime parts to be specified as body of a + ;; mime-message. In that case we implicitly create a mime-multipart + ;; and assign to the body slot. + (with-slots (real-message) part + (when (and (slot-boundp part 'real-message) + (consp real-message)) + (setf real-message + (make-instance 'mime-multipart :parts real-message))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun alist= (alist1 alist2 &key (test #'eql)) + (null + (set-difference alist1 alist2 + :test #'(lambda (x y) + (and (funcall test (car x) (car y)) + (funcall test (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime= (mime1 mime2) + (:documentation + "Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ).")) + +(defmethod mime= ((part1 mime-part) (part2 mime-part)) + (macrolet ((null-or (compare x y) + `(or (and (not ,x) + (not ,y)) + (and ,x ,y + (,compare ,x ,y)))) + (cmp-slot (compare reader) + `(null-or ,compare (,reader part1) (,reader part2)))) + (and (eq (class-of part1) (class-of part2)) + (cmp-slot string-equal mime-subtype) + (alist= (mime-type-parameters part1) + (mime-type-parameters part2) + :test #'string-equal) + (cmp-slot string= mime-id) + (cmp-slot string= mime-description) + (cmp-slot eq mime-encoding) + (cmp-slot equal mime-disposition) + (alist= (mime-disposition-parameters part1) + (mime-disposition-parameters part2) + :test #'string-equal)))) + +(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart)) + (and (call-next-method) + (every #'mime= (mime-parts part1) (mime-parts part2)))) + +(defmethod mime= ((part1 mime-message) (part2 mime-message)) + (and (call-next-method) + (alist= (mime-message-headers part1) (mime-message-headers part2) + :test #'string=) + (mime= (mime-body part1) (mime-body part2)))) + +(defun mime-body-stream (mime-part &key (binary t)) + (make-instance (if binary + 'binary-input-adapter-stream + 'character-input-adapter-stream) + :source (mime-body mime-part))) + +(defun mime-body-length (mime-part) + (be body (mime-body mime-part) + ;; here the stream type is missing on purpose, because we may not + ;; be able to size the length of a stream + (etypecase body + (string + (length body)) + (vector + (length body)) + (pathname + (file-size body)) + (file-portion + (with-open-stream (in (open-decoded-file-portion body)) + (loop + for byte = (read-byte in nil) + while byte + count byte)))))) + +(defmacro with-input-from-mime-body-stream ((stream part &key (binary t)) &body forms) + `(with-open-stream (,stream (mime-body-stream ,part :binary ,binary)) + ,@forms)) + +(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part)) + (and (call-next-method) + (with-input-from-mime-body-stream (in1 part1) + (with-input-from-mime-body-stream (in2 part2) + (loop + for b1 = (read-byte in1 nil) + for b2 = (read-byte in2 nil) + always (eq b1 b2) + while (and b1 b2)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric get-mime-type-parameter (part name) + (:documentation + "Return the MIME type parameter associated to NAME of PART.")) + +(defgeneric (setf get-mime-type-parameter) (value part name) + (:documentation + "Set the MIME type parameter associated to NAME of PART.")) + +(defmethod get-mime-type-parameter ((part mime-part) name) + (cdr (assoc name (mime-type-parameters part) :test #'string-equal))) + +(defmethod (setf get-mime-type-parameter) (value part name) + (aif (assoc name (mime-type-parameters part) :test #'string-equal) + (setf (cdr it) value) + (push (cons name value) + (mime-type-parameters part))) + value) + +(defgeneric get-mime-disposition-parameter (part name) + (:documentation + "Return the MIME disposition parameter associated to NAME of PART.")) + +(defmethod get-mime-disposition-parameter ((part mime-part) name) + (cdr (assoc name (mime-disposition-parameters part) :test #'string-equal))) + +(defmethod (setf get-mime-disposition-parameter) (value part name) + (aif (assoc name (mime-disposition-parameters part) :test #'string-equal) + (setf (cdr it) value) + (push (cons name value) + (mime-disposition-parameters part)))) + +(defmethod mime-part-file-name ((part mime-part)) + "Return the filename associated to mime PART or NIL if the mime +part doesn't have a file name." + (or (get-mime-disposition-parameter part :filename) + (get-mime-type-parameter part :name))) + +(defmethod (setf mime-part-file-name) (value (part mime-part)) + "Set the filename associated to mime PART." + (setf (get-mime-disposition-parameter part :filename) value + (get-mime-type-parameter part :name) value)) + +(defun mime-text-charset (part) + (get-mime-type-parameter part :charset)) + +(defun split-header-parts (string) + "Split parts of a MIME headers. These are divided by +semi-colons not within strings or comments." + (labels ((skip-comment (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\( (setf pos (skip-comment (1+ pos)))) + (#\\ (incf pos 2)) + (#\) (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos))) + (skip-string (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\\ (incf pos 2)) + (#\" (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos)))) + (loop + with start = 0 and i = 0 and parts = '() + while (< i (length string)) + do (case (elt string i) + (#\; (push (subseq string start i) parts) + (setf start (incf i))) + (#\" (setf i (skip-string i))) + (#\( (setf i (skip-comment (1+ i)))) + (otherwise (incf i))) + finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts))))))) + +(defun parse-parameter (string) + "Given a string like \"foo=bar\" return a pair (\"foo\" . +\"bar\"). Return NIL if string is not parsable." + (be equal-position (position #\= string) + (when equal-position + (be key (subseq string 0 equal-position) + (if (= equal-position (1- (length string))) + (cons key "") + (be value (string-trim-whitespace (subseq string (1+ equal-position))) + (cons key + (if (and (> (length value) 1) + (char= #\" (elt value 0))) + ;; the syntax of a RFC822 string is more or + ;; less the same as the Lisp one: use the Lisp + ;; reader + (or (ignore-errors (read-from-string value)) + (subseq value 1)) + (be end (or (position-if #'whitespace-p value) + (length value)) + (subseq value 0 end)))))))))) + +(defun parse-content-type (string) + "Parse string as a Content-Type MIME header and return a list +of three elements. The first is the type, the second is the +subtype and the third is an alist of parameters and their values. +Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." + (let* ((parts (split-header-parts string)) + (content-type-string (car parts)) + (slash (position #\/ content-type-string))) + ;; You'd be amazed to know how many MUA can't produce an RFC + ;; compliant message. + (when slash + (let ((type (subseq content-type-string 0 slash)) + (subtype (subseq content-type-string (1+ slash)))) + (list type subtype (remove nil (mapcar #'parse-parameter (cdr parts)))))))) + +(defun parse-content-disposition (string) + "Parse string as a Content-Disposition MIME header and return a +list. The first element is the layout, the other elements are +the optional parameters alist. +Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." + (be parts (split-header-parts string) + (cons (car parts) (mapcan #'(lambda (parameter-string) + (awhen (parse-parameter parameter-string) + (list it))) + (cdr parts))))) + +(defun parse-RFC822-header (string) + "Parse STRING which should be a valid RFC822 message header and +return two values: a string of the header name and a string of +the header value." + (be colon (position #\: string) + (when colon + (values (string-trim-whitespace (subseq string 0 colon)) + (string-trim-whitespace (subseq string (1+ colon))))))) + + +(defvar *default-type* '("text" "plain" (("charset" . "us-ascii"))) + "Internal special variable that contains the default MIME type at +any given time of the parsing phase. There are MIME container parts +that may change this.") + +(defvar *mime-types* + '((:text mime-text) + (:image mime-image) + (:audio mime-audio) + (:video mime-video) + (:application mime-application) + (:multipart mime-multipart) + (:message mime-message))) + +(defgeneric mime-part-size (part) + (:documentation + "Return the size in bytes of the body of a MIME part.")) + +(defgeneric print-mime-part (part stream) + (:documentation + "Output to STREAM one of the possible human-readable representation +of mime PART. Binary parts are omitted. This function can be used to +quote messages, for instance.")) + +(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function) + "Read through BODY-STREAM. Call CONTENTS-FUNCTION at +each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." + (let* ((boundary (s+ "--" part-boundary)) + (boundary-length (length boundary))) + (labels ((output-line (line) + (funcall contents-function line)) + (end-part () + (funcall end-part-function)) + (last-part () + (end-part) + (return-from do-multipart-parts)) + (process-line (line) + (cond ((not (string-starts-with boundary line)) + ;; normal line + (output-line line)) + ((and (= (length (string-trim-whitespace line)) + (+ 2 boundary-length)) + (string= "--" line :start2 boundary-length)) + ;; end of the last part + (last-part)) + ;; according to RFC2046 "the boundary may be followed + ;; by zero or more characters of linear whitespace" + ((= (length (string-trim-whitespace line)) boundary-length) + ;; beginning of the next part + (end-part)) + (t + ;; the line boundary is followed by some + ;; garbage; we treat it as a normal line + (output-line line))))) + (loop + for line = (read-line body-stream nil) + ;; we should never reach the end of a proper multipart MIME + ;; stream, but we don't want to be fooled by corrupted ones, + ;; so we check for EOF + unless line + do (last-part) + do (process-line line))))) + +;; This awkward handling of newlines is due to RFC2046: "The CRLF +;; preceding the boundary delimiter line is conceptually attached to +;; the boundary so that it is possible to have a part that does not +;; end with a CRLF (line break). Body parts that must be considered +;; to end with line breaks, therefore, must have two CRLFs preceding +;; the boundary delimiter line, the first of which is part of the +;; preceding body part, and the second of which is part of the +;; encapsulation boundary". +(defun split-multipart-parts (body-stream part-boundary) + "Read from BODY-STREAM and split MIME parts separated by +PART-BOUNDARY. Return a list of strings." + (let ((part (make-string-output-stream)) + (parts '()) + (beginning-of-part-p t)) + (flet ((output-line (line) + (if beginning-of-part-p + (setf beginning-of-part-p nil) + (terpri part)) + (write-string line part)) + (end-part () + (setf beginning-of-part-p t) + (push (get-output-stream-string part) parts))) + (do-multipart-parts body-stream part-boundary #'output-line #'end-part) + (close part) + ;; the first part is empty or contains all the junk + ;; to the first boundary + (cdr (nreverse parts))))) + +(defun index-multipart-parts (body-stream part-boundary) + "Read from BODY-STREAM and return the file offset of the MIME parts +separated by PART-BOUNDARY." + (let ((parts '()) + (start 0) + (len 0) + (beginning-of-part-p t)) + (flet ((sum-chars (line) + (incf len (length line)) + ;; account for the #\newline + (if beginning-of-part-p + (setf beginning-of-part-p nil) + (incf len))) + (end-part () + (setf beginning-of-part-p t) + (push (cons start (+ start len)) parts) + (setf start (file-position body-stream) + len 0))) + (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part) + ;; the first part is all the stuff up to the first boundary; + ;; just junk + (cdr (nreverse parts))))) + +(defgeneric encode-mime-part (part stream)) +(defgeneric encode-mime-body (part stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun write-mime-header (part stream) + (when (mime-version part) + (format stream "~&MIME-Version: ~A~%" (mime-version part))) + (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-type-parameters part))) + (awhen (mime-encoding part) + (format stream "Content-Transfer-Encoding: ~A~%" it)) + (awhen (mime-description part) + (format stream "Content-Description: ~A~%" it)) + (when (mime-disposition part) + (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%" + (mime-disposition part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-disposition-parameters part)))) + (awhen (mime-id part) + (format stream "Content-ID: ~A~%" it)) + (terpri stream)) + +(defmethod encode-mime-part ((part mime-part) stream) + (write-mime-header part stream) + (encode-mime-body part stream)) + +(defmethod encode-mime-part ((part mime-message) stream) + ;; tricky: we have to mix the MIME headers with the message headers + (dolist (h (mime-message-headers part)) + (unless (stringp (car h)) + (setf (car h) + (string-capitalize (car h)))) + (unless (or (string-starts-with "content-" (car h) #'string-equal) + (string-equal "mime-version" (car h))) + (format stream "~A: ~A~%" + (car h) (cdr h)))) + (encode-mime-part (mime-body part) stream)) + +(defmethod encode-mime-part ((part mime-multipart) stream) + ;; choose a boundary if not already set + (let* ((original-boundary (get-mime-type-parameter part :boundary)) + (boundary (choose-boundary (mime-parts part) original-boundary))) + (unless (and original-boundary + (string= boundary original-boundary)) + (setf (get-mime-type-parameter part :boundary) boundary)) + (call-next-method))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod encode-mime-body ((part mime-part) stream) + (with-input-from-mime-body-stream (in part) + (encode-stream in stream (mime-encoding part)))) + +(defmethod encode-mime-body ((part mime-message) stream) + (encode-mime-body (mime-body part) stream)) + +(defmethod encode-mime-body ((part mime-multipart) stream) + (be boundary (or (get-mime-type-parameter part :boundary) + (setf (get-mime-type-parameter part :boundary) + (choose-boundary (mime-parts part)))) + (dolist (p (mime-parts part)) + (format stream "~%--~A~%" boundary) + (encode-mime-part p stream)) + (format stream "~%--~A--~%" boundary))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun time-RFC822-string (&optional (epoch (get-universal-time))) + "Return a string describing the current time according to +the RFC822." + (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch) + (declare (ignore dst)) + (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D" + (subseq (week-day->string week-day) 0 3) + day (subseq (month->string month) 0 3) (mod year 100) hh mm ss + (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60)))) + +(defun parse-RFC822-date (date-string) + "Parse a RFC822 compliant date string and return an universal +time." + ;; if we can't parse it, just return NIL + (ignore-errors + ;; skip the optional DoW + (awhen (position #\, date-string) + (setf date-string (subseq date-string (1+ it)))) + (destructuring-bind (day month year time &optional tz &rest rubbish) + (split-at '(#\space #\tab) date-string) + (declare (ignore rubbish)) + (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:) + (encode-universal-time + (if ss + (read-from-string ss) + 0) + (read-from-string mm) + (read-from-string hh) + (read-from-string day) + (1+ (position month + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :test #'string-equal)) + (read-from-string year) + (when (and tz (or (char= #\+ (elt tz 0)) + (char= #\- (elt tz 0)))) + (/ (read-from-string tz) 100))))))) + +(defun read-RFC822-headers (stream &optional required-headers) + "Read RFC822 compliant headers from STREAM and return them in a +alist of keyword and string pairs. REQUIRED-HEADERS is a list of +header names we are interested in; if NIL return all headers +found in STREAM." + ;; the skip-header variable is to avoid the mistake of appending a + ;; continuation line of a header we don't want to a header we want + (loop + with headers = '() and skip-header = nil + for line = (be line (read-line stream nil) + ;; skip the Unix "From " header if present + (if (string-starts-with "From " line) + (read-line stream nil) + line)) + then (read-line stream nil) + while (and line + (not (zerop (length line)))) + do (if (whitespace-p (elt line 0)) + (unless (or skip-header + (null headers)) + (setf (cdar headers) (s+ (cdar headers) '(#\newline) line))) + (multiple-value-bind (name value) (parse-RFC822-header line) + ;; the line contained rubbish instead of an header: we + ;; play nice and return as we were at the end of the + ;; headers + (unless name + (return (nreverse headers))) + (if (or (null required-headers) + (member name required-headers :test #'string-equal)) + (progn + (push (cons name value) headers) + (setf skip-header nil)) + (setf skip-header t)))) + finally (return (nreverse headers)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-message (thing) + (:documentation + "Convert THING to a MIME-MESSAGE object.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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 delimited-input-stream)) + (be base (base-stream stream) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (etypecase base + (my-string-input-stream + (stream-string base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (file-position stream) + :end (stream-end stream))) + (call-next-method)))) + +(defmethod decode-mime-body ((part mime-part) (stream file-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (pathname stream) + :encoding (mime-encoding part) + :start (file-position stream))) + (call-next-method))) + +(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (stream-string stream) + :encoding (mime-encoding part) + :start (file-position stream))) + (call-next-method))) + +(defmethod decode-mime-body ((part mime-part) stream) + (setf (mime-body part) + (decode-stream-to-sequence stream (mime-encoding part)))) + +(defmethod decode-mime-body ((part mime-multipart) stream) + "Decode STREAM according to PART characteristics and return a +list of MIME parts." + (save-file-excursion (stream) + (be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary)) + (setf (mime-parts part) + (mapcar #'(lambda (p) + (destructuring-bind (start . end) p + (be *default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii")))) + in (make-instance 'delimited-input-stream + :stream stream + :dont-close t + :start start + :end end) + (read-mime-part in)))) + offsets))))) + +(defmethod decode-mime-body ((part mime-message) stream) + "Read from STREAM the body of PART. Return the decoded MIME +body." + (setf (mime-body part) + (read-mime-message stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) + "List of known content encodings.") + +(defun keywordify-encoding (string) + "Return a keyword for a content transfer encoding string. +Return STRING itself if STRING is an unkown encoding." + (aif (member string +known-encodings+ :test #'string-equal) + (car it) + string)) + +(defun header (name headers) + (be elt (assoc name headers :test #'string-equal) + (values (cdr elt) (car elt)))) + +(defun (setf header) (value name headers) + (be entry (assoc name headers :test #'string-equal) + (unless entry + (error "missing header ~A can't be set" name)) + (setf (cdr entry) value))) + +(defun make-mime-part (headers stream) + "Create a MIME-PART object based on HEADERS and a body which +has to be read from STREAM. If the mime part type can't be +guessed from the headers, use the *DEFAULT-TYPE*." + (flet ((hdr (what) + (header what headers))) + (destructuring-bind (type subtype parms) + (or + (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal)) + 'mime-unknown-part)) + (disp (aif (hdr :content-disposition) + (parse-content-disposition it) + (values nil nil))) + (part (make-instance class + :type (hdr :content-type) + :subtype subtype + :type-parameters parms + :disposition (car disp) + :disposition-parameters (cdr disp) + :mime-version (hdr :mime-version) + :encoding (keywordify-encoding + (hdr :content-transfer-encoding)) + :description (hdr :content-description) + :id (hdr :content-id) + :allow-other-keys t))) + (decode-mime-body part stream) + part)))) + +(defun read-mime-part (stream) + "Read mime part from STREAM. Return a MIME-PART object." + (be headers (read-rfc822-headers stream + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)) + (make-mime-part headers stream))) + +(defun read-mime-message (stream) + "Main function to read a MIME message from a stream. It +returns a MIME-MESSAGE object." + (be headers (read-rfc822-headers stream) + *default-type* '("text" "plain" (("charset" . "us-ascii"))) + (flet ((hdr (what) + (header what headers))) + (destructuring-bind (type subtype parms) + (or (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (declare (ignore type subtype)) + (make-instance 'mime-message + :headers headers + ;; this is just for easy access + :type-parameters parms + :body (make-mime-part headers stream)))))) + +(defmethod mime-message ((msg mime-message)) + msg) + +(defmethod mime-message ((msg string)) + (with-open-stream (in (make-instance 'my-string-input-stream :string msg)) + (read-mime-message in))) + +(defmethod mime-message ((msg stream)) + (read-mime-message msg)) + +(defmethod mime-message ((msg pathname)) + (let (#+sbcl(sb-impl::*default-external-format* :latin-1) + #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) + (with-open-file (in msg) + (read-mime-message in)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-part (object) + (:documentation + "Promote object, if necessary, to MIME-PART.")) + +(defmethod mime-part ((object string)) + (make-instance 'mime-text :subtype "plain" :body object)) + +(defmethod mime-part ((object pathname)) + (make-instance 'mime-application + :subtype "octect-stream" + :content-transfer-encoding :base64 + :body (read-file object :element-type '(unsigned-byte 8)))) + +(defmethod mime-part ((object mime-part)) + object) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-encoded-body-stream ((part mime-bodily-part)) + (be body (mime-body part) + (make-instance (case (mime-encoding part) + (:base64 + 'base64-encoder-input-stream) + (:quoted-printable + 'quoted-printable-encoder-input-stream) + (t + '8bit-encoder-input-stream)) + :stream (make-instance 'binary-input-adapter-stream :source body)))) + +(defun choose-boundary (parts &optional default) + (labels ((match-in-parts (boundary parts) + (loop + for p in parts + thereis (typecase p + (mime-multipart + (match-in-parts boundary (mime-parts p))) + (mime-bodily-part + (match-in-body p boundary))))) + (match-in-body (part boundary) + (with-open-stream (in (make-encoded-body-stream part)) + (loop + for line = (read-line in nil) + while line + when (string= line boundary) + return t + finally (return nil))))) + (do ((boundary (if default + (format nil "--~A" default) + #1=(format nil "--~{~36R~}" + (loop + for i from 0 below 20 + collect (random 36)))) + #1#)) + ((not (match-in-parts boundary parts)) (subseq boundary 2))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; fall back method +(defmethod mime-part-size ((part mime-part)) + (be body (mime-body part) + (typecase body + (pathname + (file-size body)) + (string + (length body)) + (vector + (length body)) + (t nil)))) + +(defmethod mime-part-size ((part mime-multipart)) + (loop + for p in (mime-parts part) + for size = (mime-part-size p) + unless size + return nil + sum size)) + +(defmethod mime-part-size ((part mime-message)) + (mime-part-size (mime-body part))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod print-mime-part ((part mime-multipart) (out stream)) + (case (mime-subtype part) + (:alternative + ;; try to choose something simple to print or the first thing + (be parts (mime-parts part) + (print-mime-part (or (find-if #'(lambda (part) + (and (eq (class-of part) (find-class 'mime-text)) + (eq (mime-subtype part) :plain))) + parts) + (car parts)) out))) + (otherwise + (dolist (subpart (mime-parts part)) + (print-mime-part subpart out))))) + +;; This is WRONG. Here we don't use any special character encoding +;; because we don't know which one we should use. Messages written in +;; anything but ASCII will likely be unreadable -wcp11/10/07. +(defmethod print-mime-part ((part mime-text) (out stream)) + (be body (mime-body part) + (etypecase body + (string + (write-string body out)) + (vector + (loop + for byte across body + do (write-char (code-char byte) out))) + (pathname + (with-open-file (in body) + (loop + for c = (read-char in nil) + while c + do (write-char c out))))))) + +(defmethod print-mime-part ((part mime-message) (out stream)) + (flet ((hdr (name) + (multiple-value-bind (value tag) + (header name (mime-message-headers part)) + (cons tag value)))) + (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id"))) + (when h + (format out "~&~A: ~A" (car h) (cdr h)))) + (format out "~2%") + (print-mime-part (mime-body part) out))) + +(defmethod print-mime-part ((part mime-part) (out stream)) + (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%" + (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-part-by-path (mime path) + (:documentation + "Return a subpart of MIME identified by PATH, which is a list of +integers. For example '(2 3 1) is the first part of the third of the +second in MIME.")) + +(defmethod find-mime-part-by-path ((part mime-part) path) + (if (null path) + part + (error "~S doesn't have subparts" part))) + +(defmethod find-mime-part-by-path ((part mime-message) path) + (if (null path) + part + (if (= 1 (car path)) + (find-mime-part-by-path (mime-body part) (cdr path)) + (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)." + part (car path))))) + +(defmethod find-mime-part-by-path ((part mime-multipart) path) + (if (null path) + part + (be parts (mime-parts part) + part-number (car path) + (if (<= 1 part-number (length parts)) + (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path)) + (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)." + part (length parts) part-number))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-part-by-id (part id) + (:documentation + "Return a subpart of PAR, whose Content-ID is the same as ID, which +is a string.")) + +(defmethod find-mime-part-by-id ((part mime-part) id) + (when (string= id (mime-id part)) + part)) + +(defmethod find-mime-part-by-id ((part mime-message) id) + (find-mime-part-by-id (mime-body part) id)) + +(defmethod find-mime-part-by-id ((part mime-multipart) id) + (or (call-next-method) + (some #'(lambda (p) + (find-mime-part-by-id p id)) + (mime-parts part)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod find-mime-text-part (msg) + (:documentation + "Return message if it is a text message or first text part. + If no suitable text part is found, return NIL.")) + +(defmethod find-mime-text-part ((part mime-text)) + part) ; found our target + +(defmethod find-mime-text-part ((msg mime-message)) + ;; mime-body is either a mime-part or mime-multipart + (find-mime-text-part (mime-body msg))) + +(defmethod find-mime-text-part ((parts mime-multipart)) + ;; multipart messages may have a body, otherwise we + ;; search for the first text part + (or (call-next-method) + (find-if #'find-mime-text-part (mime-parts parts)))) + +(defmethod find-mime-text-part ((part mime-part)) + nil) ; default case + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-type-string (mime-part) + (:documentation + "Return the string describing the MIME part.")) + +(defmethod mime-type-string ((part mime-unknown-part)) + (mime-type part)) + +(defmethod mime-type-string ((part mime-text)) + (format nil "text/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-image)) + (format nil "image/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-audio)) + (format nil "audio/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-video)) + (format nil "video/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-application)) + (format nil "application/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-multipart)) + (format nil "multipart/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-message)) + (format nil "message/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-unknown-part)) + (mime-type part)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric map-parts (function mime-part) + (:documentation + "Recursively map FUNCTION to MIME-PART or its components.")) + +;; Here we wrongly assume that we'll never want to replace messages +;; and multiparts altogether. If you need to do so you have to write +;; your own mapping functions. + +(defmethod map-parts ((function function) (part mime-part)) + (funcall function part)) + +(defmethod map-parts ((function function) (part mime-message)) + (setf (mime-body part) (map-parts function (mime-body part))) + part) + +(defmethod map-parts ((function function) (part mime-multipart)) + (setf (mime-parts part) (mapcar #'(lambda (p) + (map-parts function p)) + (mime-parts part))) + part) + +;; apply-on-parts is like map-parts but doesn't modify the parts (at least +;; not implicitly) + +(defgeneric apply-on-parts (function part)) + +(defmethod apply-on-parts ((function function) (part mime-part)) + (funcall function part)) + +(defmethod apply-on-parts ((function function) (part mime-multipart)) + (dolist (p (mime-parts part)) + (apply-on-parts function p))) + +(defmethod apply-on-parts ((function function) (part mime-message)) + (apply-on-parts function (mime-body part))) + +(defmacro do-parts ((var mime-part) &body body) + `(apply-on-parts #'(lambda (,var) ,@body) ,mime-part)) diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd new file mode 100644 index 0000000000..f3b429eafb --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl-tests.asd @@ -0,0 +1,55 @@ +;;; mime4cl-tests.asd --- system description for the regression tests + +;;; Copyright (C) 2006, 2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +#-(or sbcl) +(warn "This code hasn't been tested on your Lisp system.") + +(defpackage :mime4cl-tests-system + (:use :common-lisp :asdf #+asdfa :asdfa) + (:export #:*base-directory* + #:*compilation-epoch*)) + +(in-package :mime4cl-tests-system) + +(defsystem mime4cl-tests + :name "MIME4CL-tests" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :description "Test suite for the MIME4CL library" + :long-description + "These regression tests require rt.lisp from MIT. It is included." + :licence "LGPL" + :depends-on (:mime4cl) + :components + ((:module test + :components + ((:file "rt") + (:file "package" :depends-on ("rt")) + (:file "endec" :depends-on ("rt" "package")) + (:file "address" :depends-on ("rt" "package")) + (:file "mime" :depends-on ("rt" "package")))))) + +;; when loading this form the regression-test, the package is yet to +;; be loaded so we cannot use rt:do-tests directly or we would get a +;; reader error (unknown package) +(defmethod perform ((o test-op) (c (eql (find-system :mime4cl-tests)))) + (or (funcall (intern "DO-TESTS" "REGRESSION-TEST")) + (error "test-op failed"))) diff --git a/third_party/lisp/mime4cl/mime4cl.asd b/third_party/lisp/mime4cl/mime4cl.asd new file mode 100644 index 0000000000..6528f115d4 --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl.asd @@ -0,0 +1,49 @@ +;;; mime4cl.asd --- system definition + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or (at +;;; your option) any later version. +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; You should have received a copy of the GNU General Public License +;;; along with this program; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. + +(in-package :cl-user) + +(defpackage :mime4cl-system + (:use :common-lisp :asdf)) + +(in-package :mime4cl-system) + +(defsystem mime4cl + :name "MIME4CL" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + ;; :version "0.0" + :description "MIME primitives for Common Lisp" + :long-description + "A collection of Common Lisp primitives to forge and handle +MIME mail contents." + :licence "LGPL" + :depends-on (:npg :sclf :trivial-gray-streams) + :components + ((:file "package") + (:file "mime" :depends-on ("package" "endec" "streams")) + (:file "endec" :depends-on ("package")) + (:file "streams" :depends-on ("package" "endec")) + (:file "address" :depends-on ("package")))) + +(defmethod perform ((o test-op) (c (eql (find-system 'mime4cl)))) + (oos 'load-op 'mime4cl-tests) + (oos 'test-op 'mime4cl-tests :force t)) diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp new file mode 100644 index 0000000000..5586bdc390 --- /dev/null +++ b/third_party/lisp/mime4cl/package.lisp @@ -0,0 +1,110 @@ +;;; 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 :sclf :trivial-gray-streams) + ;; this is stuff that comes from SCLF and clashes with CMUCL's EXT + ;; package + (:shadowing-import-from :sclf + #:process-wait + #:process-alive-p + #:run-program) + (:import-from :babel :octets-to-string) + (:import-from :babel-encodings :get-character-encoding) + (: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 + #:decode-base64-stream + #:decode-base64-string + #:encode-base64-stream + #:encode-base64-sequence + #:parse-RFC2047-text + #:parse-RFC822-header + #:read-RFC822-headers + #:time-RFC822-string + #:parse-RFC822-date + #:map-parts + #:do-parts + #:apply-on-parts + #:mime-part-file-name + #:mime-text-charset + #:with-input-from-mime-body-stream + ;; endec.lisp + #:base64-encoder + #:base64-decoder + #:null-encoder + #:null-decoder + #:byte-encoder + #:byte-decoder + #:quoted-printable-encoder + #:quoted-printable-decoder + #:encoder-write-byte + #:encoder-finish-output + #:decoder-read-byte + #:decoder-read-sequence + #:*base64-line-length* + #:*quoted-printable-line-length* + ;; address.lisp + #:parse-addresses #:mailboxes-only + #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address + #:mailbox-group #:mbxg-name #:mbxg-mailboxes)) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp new file mode 100644 index 0000000000..dcac6ac341 --- /dev/null +++ b/third_party/lisp/mime4cl/streams.lisp @@ -0,0 +1,355 @@ +;;; streams.lisp --- En/De-coding Streams + +;;; Copyright (C) 2012 by Walter C. Pelissero +;;; Copyright (C) 2021-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) + +(defclass coder-stream-mixin () + ((real-stream :type stream + :initarg :stream + :reader real-stream) + (dont-close :initform nil + :initarg :dont-close))) + +(defmethod stream-file-position ((stream coder-stream-mixin)) + (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) + ()) + + +(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ()) +(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ()) +(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ()) + +(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ()) +(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ()) +(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys) + (unless (slot-boundp stream 'real-stream) + (error "REAL-STREAM is unbound. Must provide a :STREAM argument."))) + +(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'output-function) + (setf (slot-value stream 'output-function) + #'(lambda (char) + (write-char char (slot-value stream 'real-stream)))))) + +(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'input-function) + (setf (slot-value stream 'input-function) + #'(lambda () + (read-char (slot-value stream 'real-stream) nil))))) + +(defmethod stream-read-byte ((stream coder-input-stream-mixin)) + (or (decoder-read-byte stream) + :eof)) + +(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte) + (encoder-write-byte stream byte)) + +(defmethod close ((stream coder-stream-mixin) &key abort) + (with-slots (real-stream dont-close) stream + (unless dont-close + (close real-stream :abort abort)))) + +(defmethod close ((stream coder-output-stream-mixin) &key abort) + (unless abort + (encoder-finish-output stream)) + (call-next-method)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((encoder) + (buffer-queue :initform (make-queue))) + (:documentation + "This is the base class for encoders with the direction swapped. It +reads from REAL-STREAM a stream of bytes, encodes it and returnes it +in a stream of character.")) + +(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ()) +(defclass base64-encoder-input-stream (encoder-input-stream) ()) +(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ()) + +(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys) + (call-next-method) + (with-slots (encoder buffer-queue) stream + (setf encoder + (make-instance 'quoted-printable-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) + +(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys) + (call-next-method) + (with-slots (encoder buffer-queue) stream + (setf encoder + (make-instance 'base64-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) + +(defmethod stream-read-char ((stream encoder-input-stream)) + (with-slots (encoder buffer-queue real-stream) stream + (loop + while (queue-empty-p buffer-queue) + do (be byte (read-byte real-stream nil) + (if byte + (encoder-write-byte encoder byte) + (progn + (encoder-finish-output encoder) + (queue-append buffer-queue :eof))))) + (queue-pop buffer-queue))) + + +(defmethod stream-read-char ((stream 8bit-encoder-input-stream)) + (with-slots (real-stream) stream + (aif (read-byte real-stream nil) + (code-char it) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass input-adapter-stream () + ((source :initarg :source) + (real-stream) + (input-function))) + +(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ()) + +(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ()) + +(defmethod stream-element-type ((stream binary-input-adapter-stream)) + '(unsigned-byte 8)) + +(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys) + (call-next-method) + (assert (slot-boundp stream 'source))) + +(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys) + (call-next-method) + ;; REAL-STREAM slot is set only if we are going to close it later on + (with-slots (source real-stream input-function) stream + (etypecase source + (string + (setf real-stream (make-string-input-stream source) + input-function #'(lambda () + (awhen (read-char real-stream nil) + (char-code it))))) + ((vector (unsigned-byte 8)) + (be i 0 + (setf input-function #'(lambda () + (when (< i (length source)) + (prog1 (aref source i) + (incf i))))))) + (stream + (assert (input-stream-p source)) + (setf input-function (if (subtypep (stream-element-type source) 'character) + #'(lambda () + (awhen (read-char source nil) + (char-code it))) + #'(lambda () + (read-byte source nil))))) + (pathname + (setf real-stream (open source :element-type '(unsigned-byte 8)) + input-function #'(lambda () + (read-byte real-stream nil)))) + (file-portion + (setf real-stream (open-decoded-file-portion source) + input-function #'(lambda () + (read-byte real-stream nil))))))) + +(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys) + (call-next-method) + ;; REAL-STREAM slot is set only if we are going to close later on + (with-slots (source real-stream input-function) stream + (etypecase source + (string + (setf real-stream (make-string-input-stream source) + input-function #'(lambda () + (read-char real-stream nil)))) + ((vector (unsigned-byte 8)) + (be i 0 + (setf input-function #'(lambda () + (when (< i (length source)) + (prog1 (code-char (aref source i)) + (incf i))))))) + (stream + (assert (input-stream-p source)) + (setf input-function (if (subtypep (stream-element-type source) 'character) + #'(lambda () + (read-char source nil)) + #'(lambda () + (awhen (read-byte source nil) + (code-char it)))))) + (pathname + (setf real-stream (open source :element-type 'character) + input-function #'(lambda () + (read-char real-stream nil)))) + (file-portion + (setf real-stream (open-decoded-file-portion source) + input-function #'(lambda () + (awhen (read-byte real-stream nil) + (code-char it)))))))) + +(defmethod close ((stream input-adapter-stream) &key abort) + (when (slot-boundp stream 'real-stream) + (with-slots (real-stream) stream + (close real-stream :abort abort)))) + +(defmethod stream-read-byte ((stream binary-input-adapter-stream)) + (with-slots (input-function) stream + (or (funcall input-function) + :eof))) + +(defmethod stream-read-char ((stream character-input-adapter-stream)) + (with-slots (input-function) stream + (or (funcall input-function) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((start-offset :initarg :start + :initform 0 + :reader stream-start + :type integer) + (end-offset :initarg :end + :initform nil + :reader stream-end + :type (or null integer)) + (current-offset :type integer))) + +(defmethod print-object ((object delimited-input-stream) stream) + (if *print-readably* + (call-next-method) + (with-slots (start-offset end-offset) object + (print-unreadable-object (object stream :type t :identity t) + (format stream "start=~A end=~A" start-offset end-offset))))) + +(defun base-stream (stream) + (if (typep stream 'delimited-input-stream) + (base-stream (real-stream stream)) + stream)) + +(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'real-stream) + (error "REAL-STREAM is unbound. Must provide a :STREAM argument.")) + (with-slots (start-offset) stream + (file-position stream start-offset))) + +(defmethod (setf stream-file-position) (newval (stream delimited-input-stream)) + (with-slots (current-offset real-stream) stream + (setf current-offset newval) + (call-next-method))) + +(defmethod stream-file-position ((stream delimited-input-stream)) + (slot-value stream 'current-offset)) + +;; Calling file-position with SBCL on every read is quite expensive, since +;; it will invoke lseek each time. This is so expensive that it's faster to +;; /compute/ the amount the stream got advanced by. +;; file-position's behavior however, is quite flexible and it behaves differently +;; not only for different implementation, but also different streams in SBCL. +;; Thus, we should ideally go back to file-position and try to reduce the amount +;; of calls by using read-sequence. +;; TODO(sterni): make decoders use read-sequence and drop offset tracking code +(macrolet ((def-stream-read (name read-fun update-offset-form) + `(defmethod ,name ((stream delimited-input-stream)) + (with-slots (real-stream end-offset current-offset) stream + (let ((el (if (or (not end-offset) + (< current-offset end-offset)) + (or (,read-fun real-stream nil) + :eof) + :eof))) + (setf current-offset ,update-offset-form) + el))))) + + ;; Assume we are using an encoding where < 128 is one byte, in all other cases + ;; it's hard to guess how much file-position will increase + (def-stream-read stream-read-char read-char + (if (or (eq el :eof) (< (char-code el) 128)) + (1+ current-offset) + (file-position real-stream))) + + (def-stream-read stream-read-byte read-byte (1+ current-offset))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((string :initarg :string + :reader stream-string))) + +(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys) + (call-next-method) + (assert (slot-boundp stream 'string)) + (with-slots (string real-stream) stream + (setf real-stream (make-string-input-stream string)))) + +(defmethod stream-read-char ((stream my-string-input-stream)) + (with-slots (real-stream) stream + (or (read-char real-stream nil) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct file-portion + data ; string or a pathname + encoding + start + end) + +(defun open-file-portion (file-portion) + (be data (file-portion-data file-portion) + (etypecase data + (pathname + (be stream (open data) + (make-instance 'delimited-input-stream + :stream stream + :start (file-portion-start file-portion) + :end (file-portion-end file-portion)))) + (string + (make-instance 'delimited-input-stream + :stream (make-string-input-stream data) + :start (file-portion-start file-portion) + :end (file-portion-end file-portion))) + (stream + (make-instance 'delimited-input-stream + :stream data + :dont-close t + :start (file-portion-start file-portion) + :end (file-portion-end file-portion)))))) + +(defun open-decoded-file-portion (file-portion) + (make-instance (case (file-portion-encoding file-portion) + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'base64-decoder-stream) + (t '8bit-decoder-stream)) + :stream (open-file-portion file-portion))) diff --git a/third_party/lisp/mime4cl/test/address.lisp b/third_party/lisp/mime4cl/test/address.lisp new file mode 100644 index 0000000000..a3653985c4 --- /dev/null +++ b/third_party/lisp/mime4cl/test/address.lisp @@ -0,0 +1,123 @@ +;;; address.lisp --- tests for the e-mail address parser + +;;; Copyright (C) 2007, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defun test-parsing (string) + (format nil "~{~A~^, ~}" (parse-addresses string))) + +(deftest address-parse-simple.1 + (test-parsing "foo@bar") + "foo@bar") + +(deftest address-parse-simple.2 + (test-parsing "foo@bar.com") + "foo@bar.com") + +(deftest address-parse-simple.3 + (test-parsing "foo@bar.baz.com") + "foo@bar.baz.com") + +(deftest address-parse-simple.4 + (test-parsing "foo.ooo@bar.baz.com") + "foo.ooo@bar.baz.com") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-simple-commented.1 + (test-parsing "foo@bar (Some Comment)") + "\"Some Comment\" <foo@bar>") + +(deftest address-parse-simple-commented.2 + (test-parsing "foo@bar (Some, Comment)") + "\"Some, Comment\" <foo@bar>") + +(deftest address-parse-simple-commented.3 + (test-parsing "foo@bar (Some Comment (yes, indeed))") + "\"Some Comment (yes, indeed)\" <foo@bar>") + +(deftest address-parse-simple-commented.4 + (test-parsing "foo.bar@host.complicated.domain.net (Some Comment (yes, indeed))") + "\"Some Comment (yes, indeed)\" <foo.bar@host.complicated.domain.net>") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-angle.1 + (test-parsing "<foo@bar.baz.net>") + "foo@bar.baz.net") + +(deftest address-parse-angle.2 + (test-parsing "My far far friend <foo@bar.baz.net>") + "\"My far far friend\" <foo@bar.baz.net>") + +(deftest address-parse-angle.3 + (test-parsing "\"someone, I don't like\" <foo@bar.baz.net>") + "\"someone, I don't like\" <foo@bar.baz.net>") + +(deftest address-parse-angle.4 + (test-parsing "\"this could (be a comment)\" <foo@bar.net>") + "\"this could (be a comment)\" <foo@bar.net>") + +(deftest address-parse-angle.5 + (test-parsing "don't be fooled <foo@bar.net>") + "\"don't be fooled\" <foo@bar.net>") + +(deftest address-parse-angle.6 + (test-parsing "<foo@bar>") + "foo@bar") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-domain-literal.1 + (test-parsing "<foo@[bar]>") + "foo@[bar]") + +(deftest address-parse-domain-literal.2 + (test-parsing "<foo@[bar.net]>") + "foo@[bar.net]") + +(deftest address-parse-domain-literal.3 + (test-parsing "<foo@[10.0.0.2]>") + "foo@[10.0.0.2]") + +(deftest address-parse-domain-literal.4 + (test-parsing "<foo.bar@[10.0.0.2]>") + "foo.bar@[10.0.0.2]") + +(deftest address-parse-domain-literal.5 + (test-parsing "somewhere unkown <foo.bar@[10.0.0.2]>") + "\"somewhere unkown\" <foo.bar@[10.0.0.2]>") + +(deftest address-parse-domain-literal.6 + (test-parsing "\"Some--One\" <foo.bar@[10.0.0.23]>") + "\"Some--One\" <foo.bar@[10.0.0.23]>") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-group.1 + (test-parsing "friends:john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];") + "friends: john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-mixed.1 + (test-parsing "Foo BAR <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends:john@bar,jack@pub;, foo.bar.baz@wow.mail.mine, dont.bark@me (Fierce Dog)") + "\"Foo BAR\" <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends: john@bar, jack@pub;, foo.bar.baz@wow.mail.mine, \"Fierce Dog\" <dont.bark@me>") diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp new file mode 100644 index 0000000000..5e8d43a7d4 --- /dev/null +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -0,0 +1,166 @@ +;;; 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 + (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + "Some random string.") + +(deftest base64.4 + (map 'string #'code-char + (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" + :start 13 :end 41)) + "Some random string.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest RFC2047.1 + (parse-RFC2047-text "foo bar") + ("foo bar")) + +(defun perftest-encoder (encoder-class &optional (megs 100)) + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type fixnum megs)) + (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) (declare (ignore c)))))) + (declare (type fixnum meg)) + (time + (progn + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder)))))) + +(defun perftest-decoder (decoder-class &optional (megs 100)) + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type fixnum megs)) + (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) + (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) + :type "encoded-data"))) + (sclf:with-temp-file (tmp nil :direction :io) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder-class (ecase decoder-class + (mime4cl:base64-decoder 'mime4cl:base64-encoder) + (mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder))) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) + (write-char c tmp)))) + (decoder (make-instance decoder-class + :input-function #'(lambda () + (read-char tmp nil))))) + (declare (type fixnum meg)) + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder) + (file-position tmp 0) + (time + (loop + for b = (mime4cl:decoder-read-byte decoder) + while b))))))) diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp new file mode 100644 index 0000000000..8d93978599 --- /dev/null +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -0,0 +1,54 @@ +;;; mime.lisp --- MIME regression tests + +;;; Copyright (C) 2012 by Walter C. Pelissero +;;; Copyright (C) 2021-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) + +(defvar *samples-directory* + (merge-pathnames (make-pathname :directory '(:relative "samples")) + #.(or *compile-file-pathname* + *load-pathname* + #P""))) + +(defvar *sample1-file* (make-pathname :defaults #.(or *compile-file-pathname* + *load-pathname*) + :name "sample1" + :type "msg")) + +(deftest mime.1 + (let* ((orig (mime-message *sample1-file*)) + (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (mime= orig dup)) + t) + +(deftest mime.2 + (loop + for f in (directory (make-pathname :defaults *samples-directory* + :name :wild + :type "txt")) + do + (format t "~A:~%" f) + (finish-output) + (let* ((orig (mime-message f)) + (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (unless (mime= orig dup) + (return nil))) + finally (return t)) + t) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp new file mode 100644 index 0000000000..6da1fc8fa2 --- /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) + (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp new file mode 100644 index 0000000000..06160debbe --- /dev/null +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -0,0 +1,254 @@ +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +(defpackage #:regression-test + (:nicknames #:rtest #-lispworks #:rt) + (:use #:cl) + (:export #:*do-tests-when-defined* #:*test* #:continue-testing + #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) + (:documentation "The MIT regression tester with pfdietz's modifications")) + +(in-package :regression-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t + "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") +(defvar *compile-tests* nil + "When true, compile the tests before running them.") +(defvar *optimization-settings* '((safety 3))) +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters." + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (null pending)))) diff --git a/third_party/lisp/mime4cl/test/sample1.msg b/third_party/lisp/mime4cl/test/sample1.msg new file mode 100644 index 0000000000..662a9fab34 --- /dev/null +++ b/third_party/lisp/mime4cl/test/sample1.msg @@ -0,0 +1,86 @@ +From wcp@scylla.home.lan Fri Feb 17 11:02:28 2012 +Status: RO +X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil] + ["1133" "Friday" "17" "February" "2012" "11:02:27" "+0100" "Walter C. Pelissero" "walter@pelissero.de" nil "56" "test" "^From:" nil nil "2" nil nil nil nil nil nil nil nil nil nil] + nil) +X-Clpmr-Processed: 2012-02-17T11:02:31 +X-Clpmr-Version: 2011-10-23T12:55:20, SBCL 1.0.49 +Received: from scylla.home.lan (localhost [127.0.0.1]) + by scylla.home.lan (8.14.5/8.14.5) with ESMTP id q1HA2Sik004513 + for <wcp@scylla.home.lan>; Fri, 17 Feb 2012 11:02:28 +0100 (CET) + (envelope-from wcp@scylla.home.lan) +Received: (from wcp@localhost) + by scylla.home.lan (8.14.5/8.14.5/Submit) id q1HA2SqU004512; + Fri, 17 Feb 2012 11:02:28 +0100 (CET) + (envelope-from wcp) +Message-ID: <20286.9651.890757.323027@scylla.home.lan> +X-Mailer: VM 8.1.1 under 23.3.1 (amd64-portbld-freebsd8.2) +Reply-To: walter@pelissero.de +X-Attribution: WP +X-For-Spammers: blacklistme@pelissero.de +X-MArch-Processing-Time: 0.552s +MIME-Version: 1.0 +Content-Type: multipart/mixed; boundary="615CiWUaGO" +Content-Transfer-Encoding: 7BIT +From: walter@pelissero.de (Walter C. Pelissero) +To: wcp@scylla.home.lan +Subject: test +Date: Fri, 17 Feb 2012 11:02:27 +0100 + + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + +Hereafter three attachments. + +The first: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach1" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach1" + +YXR0YWNoMQo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + + +The second: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach2" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach2" + +YXR0YWNoMgo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + + +The third: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach3" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach3" + +YXR0YWNoMwo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: .signature + + +-- +http://pelissero.de +--615CiWUaGO-- + diff --git a/third_party/lisp/moptilities.nix b/third_party/lisp/moptilities.nix new file mode 100644 index 0000000000..d38fbcb946 --- /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 0000000000..b71f439c93 --- /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 0000000000..82a8fe48bb --- /dev/null +++ b/third_party/lisp/npg/.project @@ -0,0 +1 @@ +NPG a Naive Parser Generator diff --git a/third_party/lisp/npg/.skip-subtree b/third_party/lisp/npg/.skip-subtree new file mode 100644 index 0000000000..5051f60d6b --- /dev/null +++ b/third_party/lisp/npg/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING new file mode 100644 index 0000000000..223ede7de3 --- /dev/null +++ b/third_party/lisp/npg/COPYING @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/third_party/lisp/npg/OWNERS b/third_party/lisp/npg/OWNERS new file mode 100644 index 0000000000..f16dd105d7 --- /dev/null +++ b/third_party/lisp/npg/OWNERS @@ -0,0 +1,3 @@ +inherited: true +owners: + - sterni diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README new file mode 100644 index 0000000000..a1661e744a --- /dev/null +++ b/third_party/lisp/npg/README @@ -0,0 +1,48 @@ + + NPG a Naive Parser Generator + for Common Lisp + + Copyright (C) 2003-2006, 2010 by Walter C. Pelissero + Copyright (C) 2021 by the TVL Authors + +Vendored into depot as it is a dependency of mime4cl and upstream has +become inactive. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#npg +Vendored Tarball: http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz + +This library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation; either version 2.1 of the +License, or (at your option) any later version. This library is +distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. You should have received a copy of the GNU +Lesser General Public License along with this library; if not, write +to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +Boston, MA 02111-1307 USA + + +This library generates on the fly (no external representation of the +parser is produced) a recursive descent parser based on the grammar +rules you have fed it with. The parser object can then be used to +scan tokenised input. Although a facility to produce a lexical +analiser is not provided, to write such a library is fairly easy for +most languages. NPG parsers require your lexer to adhere to a certain +protocol to be able to communicate with them. Examples are provided +that explain these requirements. + +While quite possibly not producing the fastest parsers in town, it's +fairly simple and hopefully easy to debug. It accepts a lispy EBNF +grammar description of arbitrary complexity with the exception of +mutually left recursive rules (watch out, they produce undetected +infinite recursion) and produces a backtracking recursive descent +parser. Immediate left recursive rules are properly simplified, +though. + +Multiple concurrent parsers are supported. + +To compile, an ASDF and nix file are provided. + +See the examples directory for clues on how to use it. diff --git a/third_party/lisp/npg/default.nix b/third_party/lisp/npg/default.nix new file mode 100644 index 0000000000..af7ec53eaf --- /dev/null +++ b/third_party/lisp/npg/default.nix @@ -0,0 +1,14 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "npg"; + + srcs = [ + ./src/package.lisp + ./src/common.lisp + ./src/define.lisp + ./src/parser.lisp + ]; +} diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp new file mode 100644 index 0000000000..a45ac614f7 --- /dev/null +++ b/third_party/lisp/npg/examples/python.lisp @@ -0,0 +1,336 @@ +;;; python.lisp --- sample grammar definition for the Python language + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is far from being a complete Python grammar. Actually I +;;; haven't even read a Python book before starting to write this +;;; stuff, so the code below comes mostly from wild guessing while +;;; reading a Python source file. +;;; +;;; It's a design decision to avoid writing any transformation in this +;;; module; only tagging is done at this level. This improves the +;;; separation between parsing and transformation, making the grammar +;;; reusable for other purposes. + + +#+cmu (ext:file-comment "$Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $") + +(in-package :grammar) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "~&creating Python grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () + +(defrule program + := comment-string? statement+) + +(defrule comment-string + := string eol + :reduce string) + +;;; BOB = Beginning Of Block, EOB = End Of Block. It's lexical +;;; analyzer's task to find out where a statement or block starts/ends. + +(defrule suite + := statement-list eol + :reduce statement-list + := statement-block) + +(defrule commentable-suite + := statement-list eol + :reduce statement-list + := commented-statement-block) + +(defrule statement-block + := bob statement+ eob + :reduce $2) + +(defrule commented-statement-block + := bob comment-string? statement* eob + :reduce (cons comment-string statement)) + +(defrule statement-list + := (+ simple-statement ";") + :reduce (if (cdr $1) + (cons :statement-list $1) + (car $1))) + +(defrule statement + := statement-list eol + :reduce statement-list + := compound-statement) + +(defrule simple-statement + := import-statement + := raise-statement + := assignment + := function-call + := return-statement + := assert-statement + := pass-statement + := break-statement + := continue-statement) + +(defrule compound-statement + := class-definition + := method-definition + := try-statement + := if-statement + := while-statement + := for-statement) + +(defrule import-statement + := "import" (+ package-name ",") + :tag :import + := "from" package-name "import" (+ symbol-name ",") + :tag :import-from) + +(defrule package-name := identifier) + +(defrule symbol-name + := identifier + := "*") + +(defrule try-statement + := "try" ":" suite try-except-part* try-finally-part? + :tag :try) + +(defrule try-except-part + := "except" exception-subject? ":" suite) + +(defrule try-finally-part + := "finally" ":" suite) + +(defrule exception-subject + := exception-name exception-variable?) + +(defrule exception-variable + := "," identifier) + +(defrule exception-name := class-name) + +(defrule class-name := identifier) + +(defrule raise-statement + := "raise" + :tag :raise-same + := "raise" exception-name + :tag :raise + := "raise" exception-name "," expression + :tag :raise + := "raise" exception-name "(" expression ")" + :tag :raise) + +(defrule assignment + := (+ variable-with-optional-subscript ",") "=" more-assignment + :tag :set) + +(defrule more-assignment + := expression + := assignment) + +(defrule variable-with-optional-subscript + := variable-name subscript + :tag :subscript + := variable-name) + +(defrule variable-name + := (+ identifier ".") + :tag :varef) + +(defrule expression + := expression "or" expression1 + :tag :or + := expression1) + +(defrule expression1 + := expression1 "and" expression2 + :tag :and + := expression2) + +(defrule expression2 + := expression2 "==" expression3 + :tag :equal + := expression2 ">=" expression3 + :tag :more-equal + := expression2 "<=" expression3 + :tag :less-equal + := expression2 "!=" expression3 + :tag :not-equal + := expression2 ">" expression3 + :tag :more + := expression2 "<" expression3 + :tag :less + := expression2 "is" expression3 + :tag :equal + := expression2 "is" "not" expression3 + :tag :not-equal + := expression3) + +(defrule expression3 + := expression3 "+" expression4 + :tag :plus + := expression3 "-" expression4 + :tag :minus + := expression3 "|" expression4 + :tag :bit-or + := expression4) + +;; high priority expression +(defrule expression4 + := expression4 "*" expression5 + :tag :mult + := expression4 "/" expression5 + :tag :div + := expression4 "%" expression5 + :tag :modulo + := expression4 "&" expression5 + :tag :bit-and + := expression4 "in" expression5 + :tag :in + := expression5) + +(defrule expression5 + := "~" expression5 + :tag :bit-not + := "not" expression5 + :tag :not + := "(" expression ")" + := expression6) + +(defrule expression6 + := simple-expression subscript + :tag :subscript + := simple-expression) + +(defrule simple-expression + := function-call + := variable-name + := constant + := string-conversion + := list-constructor) + +(defrule subscript + := "[" expression "]" + := "[" expression ":" expression "]" + := "[" expression ":" "]" + :reduce (list expression nil) + := "[" ":" expression "]" + :reduce (list nil expression)) + +(defrule string-conversion + := "`" expression "`" + :tag :to-string) + +(defrule constant + := number + := string + := lambda-expression) + +(defrule number + := float + := integer) + +(defrule list-constructor + := "[" (* expression ",") "]" + :tag :make-list) + +(defrule class-definition + := "class" class-name superclasses? ":" commentable-suite + :tag :defclass) + +(defrule superclasses + := "(" class-name+ ")") + +(defrule method-definition + := "def" method-name "(" method-arguments ")" ":" commentable-suite + :tag :defmethod) + +(defrule method-arguments + := (* method-argument ",")) + +(defrule method-argument + := identifier argument-default?) + +(defrule argument-default + := "=" expression) + +(defrule method-name := identifier) + +(defrule if-statement + := "if" expression ":" suite elif-part* else-part? + :tag :if) + +(defrule else-part + := "else" ":" suite) + +(defrule elif-part + := "elif" expression ":" suite) + +(defrule lambda-expression + := "lambda" method-arguments ":" expression + :tag :lambda) + +(defrule function-call + := (+ identifier ".") "(" (* expression ",") ")" + :tag :funcall) + +(defrule for-statement + := "for" identifier "in" expression ":" suite + :tag :do-list + := "for" identifier "in" "range" "(" expression "," expression ")" ":" suite + :tag :do-range) + +(defrule while-statement + := "while" expression ":" suite + :tag :while) + +(defrule return-statement + := "return" expression? + :tag :return) + +(defrule assert-statement + := "assert" expression "," string + :tag :assert) + +(defrule pass-statement + := "pass" + :tag :pass) + +(defrule break-statement + := "break" + :tag :break) + +(defrule continue-statement + := "continue" + :tag :continue) + +) ; end of POPULATE-GRAMMAR diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp new file mode 100644 index 0000000000..9ebd45a169 --- /dev/null +++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp @@ -0,0 +1,1901 @@ +;;; vs-cobol-ii.lisp --- sample grammar for VS-Cobol II + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; A fairly incomplete VS-Cobol II grammar fro NPG. It's probably +;;; not very accurate either. + +#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $") + +(in-package :grammar) + +(defun make-keyword (string) + "Create a keyword from STRING." + (intern (string-upcase string) :keyword)) + +(defun flatten-list (list) + "Remove one depth level in LIST." + (mapcan #'identity list)) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "creating Cobol grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () +;;; +;;; Hereafter PP means Partial Program +;;; + +#+nil +(defrule pp--declarations + := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest) + +;;; We need to split the parsing of the declarations from the rest +;;; because the declarations may change the lexical rules (ie decimal +;;; point) + +(defrule pp--declarations + := identification-division environment-division? data-division-head-or-procedure-division-head :rest) + +(defrule data-division-head-or-procedure-division-head + := data-division-head + :reduce :data-division + := procedure-division-head + :reduce (list :procedure-division $1)) + +(defrule pp--data-division + := data-division-content procedure-division-head :rest) + +(defrule pp--sentence + := sentence :rest + := :eof) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The real grammar +;;; + +(defrule cobol-source-program + := identification-division environment-division? data-division procedure-division end-program?) + +(defrule identification-division + := identification "DIVISION" "." program-id-cobol-source-program identification-division-content + :reduce program-id-cobol-source-program) + +(defrule priority-number + := integer) + +(defrule level-number + := integer) + +(defrule to-id-or-lit + := "TO" id-or-lit) + +(defrule inspect-by-argument + := variable-identifier + := string + := figurative-constant-simple) + +(defrule figurative-constant-simple + := "ZERO" + :reduce :zero + := "ZEROS" + :reduce :zero + := "ZEROES" + :reduce :zero + := "SPACE" + :reduce :space + := "SPACES" + :reduce :space + := "HIGH-VALUE" + :reduce :high + := "HIGH-VALUES" + :reduce :high + := "LOW-VALUE" + :reduce :low + := "LOW-VALUES" + :reduce :low + := "QUOTE" + :reduce :quote + := "QUOTES" + :reduce :quote + := "NULL" + :reduce :null + := "NULLS" + :reduce :null) + +(defrule write-exceptions + := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?) + +(defrule set-statement-phrase + := variable-identifier+ set-oper set-src) + +(defrule set-src + := variable-identifier + := literal + := "TRUE" + := "ON" + := "OFF") + +(defrule set-oper + := "TO" + :reduce :to + := "UP" "BY" + :reduce :up + := "DOWN" "BY" + :reduce :down) + +(defrule fce-phrase + := reserve-clause + := fce-organization + := fce-access-mode + := record-key-clause + := password-clause + := alternate-record-key-clause + := file-status-clause + := padding-character-clause + := record-delimiter-clause) + +(defrule fce-organization + := organization-is? alt-indexed-relative-sequential + :reduce (list :organization (make-keyword alt-indexed-relative-sequential))) + +(defrule fce-access-mode + := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause? + :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic))) + +(defrule alt-indexed-relative-sequential + := "INDEXED" + := "RELATIVE" + := "SEQUENTIAL") + +(defrule is-not + := "IS"? "NOT"?) + +(defrule all-procedures + := "ALL" "PROCEDURES") + +(defrule next-sentence + := "NEXT" "SENTENCE") + +(defrule no-rewind + := "NO" "REWIND") + +(defrule for-removal + := "FOR"? "REMOVAL") + +(defrule values + := "VALUE" + := "VALUES") + +(defrule records + := "RECORD" + := "RECORDS") + +(defrule end-program + := "END" "PROGRAM" program-name ".") + +(defrule environment-division + := "ENVIRONMENT" "DIVISION" "." environment-division-content) + +(defrule data-division-head + := "DATA" "DIVISION" ".") + +(defrule data-division + := data-division-head data-division-content + :reduce data-division-content) + +(defrule identification + := "IDENTIFICATION" + := "ID") + +(defrule identification-division-content + := identification-division-phrase*) + +(defrule author + := "AUTHOR" ".") + +(defrule installation + := "INSTALLATION" ".") + +(defrule date-written + := "DATE-WRITTEN" ".") + +(defrule date-compiled + := "DATE-COMPILED" ".") + +(defrule security + := "SECURITY" ".") + +(defrule remarks + := "REMARKS" ".") + +(defrule identification-division-phrase + := author + := installation + := date-written + := date-compiled + := security + := remarks) + +(defrule program-id-cobol-source-program + := "PROGRAM-ID" "."? program-name initial-program? "." + :reduce program-name) + +(defrule initial-program + := "IS"? "INITIAL" "PROGRAM"?) + +(defrule environment-division-content + := configuration-section? input-output-section?) + +(defrule input-output-section + := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph? + :reduce file-control-paragraph) + +(defrule file-control-paragraph + := "FILE-CONTROL" "." file-control-entry*) + +(defrule file-control-entry + := select-clause assign-clause fce-phrase* "." + :reduce (append select-clause + assign-clause + (flatten-list fce-phrase))) + +(defrule organization-is + := "ORGANIZATION" "IS"?) + +(defrule alt-sequential-random-dynamic + := "SEQUENTIAL" + := "RANDOM" + := "DYNAMIC") + +(defrule select-clause + := "SELECT" "OPTIONAL"? file-name + :reduce (list file-name :optional (and $2 t))) + +(defrule assign-clause + := "ASSIGN" "TO"? alt-assignment-name-literal+ + :reduce (list :assign alt-assignment-name-literal)) + +(defrule alt-assignment-name-literal + := assignment-name + := literal) + +(defrule reserve-clause + := "RESERVE" integer areas?) + +(defrule areas + := "AREA" + := "AREAS") + +(defrule padding-character-clause + := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal) + +(defrule record-delimiter-clause + := "RECORD" "DELIMITER" "IS"? record-delimiter-name) + +(defrule record-delimiter-name + := "STANDARD-1" + := assignment-name) + +(defrule password-clause + := "PASSWORD" "IS"? data-name) + +(defrule file-status-clause + := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name? + :reduce (list :file-status qualified-data-name)) + +(defrule relative-key-clause + := "RELATIVE" "KEY"? "IS"? qualified-data-name + :reduce (list :relative-key qualified-data-name)) + +(defrule record-key-clause + := "RECORD" "KEY"? "IS"? qualified-data-name + :reduce (list :key qualified-data-name)) + +(defrule alternate-record-key-clause + := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates? + :reduce (list :alternate-key qualified-data-name with-duplicates)) + +(defrule with-duplicates + := "WITH"? "DUPLICATES") + +(defrule i-o-control-paragraph + := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?) + +(defrule i-o-sam + := qsam-or-sam-or-vsam-i-o-control-entries+ ".") + +(defrule i-o-sort-merge + := sort-merge-i-o-control-entries ".") + +(defrule qsam-or-sam-or-vsam-i-o-control-entries + := qsam-or-sam-or-vsam-i-o-control-entries-1 + := qsam-or-sam-or-vsam-i-o-control-entries-2 + := qsam-or-sam-or-vsam-i-o-control-entries-3 + := qsam-or-sam-or-vsam-i-o-control-entries-4) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-1 + := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name) + +(defrule every-phrase-1 + := integer "RECORDS") + +(defrule every-phrase-2 + := "END" "OF"? alt-reel-unit) + +(defrule every-phrase + := every-phrase-1 + := every-phrase-2) + +(defrule alt-assignment-name-file-name + := assignment-name + := file-name) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-2 + := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-3 + := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+) + +(defrule position + := "POSITION" integer) + +(defrule file-name-position + := file-name position?) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-4 + := "APPLY" "WRITE-ONLY" "ON"? file-name+) + +(defrule sort-merge-i-o-control-entries + := rerun-on? same-area+) + +(defrule rerun-on + := "RERUN" "ON" assignment-name) + +(defrule record-sort + := "RECORD" + := "SORT" + := "SORT-MERGE") + +(defrule same-area + := "SAME" record-sort "AREA"? "FOR"? file-name file-name+) + +(defrule configuration-section + := "CONFIGURATION" "SECTION" "." configuration-section-paragraph* + :reduce (flatten-list configuration-section-paragraph)) + +(defrule configuration-section-paragraph + := source-computer-paragraph + := object-computer-paragraph + := special-names-paragraph) + +(defrule source-computer-paragraph + := "SOURCE-COMPUTER" "." source-computer-name + :reduce (list :source-computer source-computer-name)) + +(defrule with-debugging-mode + := "WITH"? "DEBUGGING" "MODE") + +(defrule source-computer-name + := computer-name with-debugging-mode? "." + :reduce computer-name) + +(defrule object-computer-paragraph + := "OBJECT-COMPUTER" "." object-computer-name + :reduce (list :object-computer object-computer-name)) + +(defrule memory-size-type + := "WORDS" + := "CHARACTERS" + := "MODULES") + +(defrule memory-size + := "MEMORY" "SIZE"? integer memory-size-type) + +(defrule object-computer-name + := computer-name memory-size? object-computer-paragraph-sequence-phrase "." + :reduce computer-name) + +(defrule object-computer-paragraph-sequence-phrase + := program-collating-sequence? segment-limit?) + +(defrule program-collating-sequence + := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule segment-limit + := "SEGMENT-LIMIT" "IS"? priority-number) + +(defrule special-names-paragraph + := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "." + :reduce (flatten-list special-names-paragraph-clause)) + +(defrule is-mnemonic-name + := "IS"? mnemonic-name special-names-paragraph-status-phrase?) + +(defrule special-names-paragraph-phrase-tail + := is-mnemonic-name + := special-names-paragraph-status-phrase) + +(defrule special-names-paragraph-phrase + := environment-name special-names-paragraph-phrase-tail) + +(defrule special-names-paragraph-status-phrase + := special-names-paragraph-status-phrase-1 + := special-names-paragraph-status-phrase-2) + +(defrule special-names-paragraph-status-phrase-1 + := "ON" "STATUS"? "IS"? condition off-status?) + +(defrule off-status + := "OFF" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-status-phrase-2 + := "OFF" "STATUS"? "IS"? condition on-status?) + +(defrule on-status + := "ON" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-clause + ;; := alphabet-clause + ;; := symbolic-characters-clause + := currency-sign-clause + := decimal-point-clause) + +(defrule alphabet-clause + := "ALPHABET" alphabet-name "IS"? alphabet-type) + +(defrule alphabet-type-also + := "ALSO" literal) + +(defrule alphabet-type-alsos + := alphabet-type-also+) + +(defrule alphabet-type-also-through + := through-literal + := alphabet-type-alsos) + +(defrule alphabet-type-other + := literal alphabet-type-also-through?) + +(defrule alphabet-type-others + := alphabet-type-other+) + +(defrule alphabet-type + := "STANDARD-1" + := "STANDARD-2" + := "NATIVE" + := "EBCDIC" + := alphabet-type-others) + +(defrule symbolic-characters-clause + := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?) + +(defrule are + := "ARE" + := "IS") + +(defrule symbolic-character-mapping + := symbolic-character+ are? integer+) + +(defrule in-alphabet-name + := "IN" alphabet-name) + +(defrule currency-sign-clause + := "CURRENCY" "SIGN"? "IS"? literal + :reduce (list :currency-sign literal)) + +(defrule decimal-point-clause + := "DECIMAL-POINT" "IS"? "COMMA" + :reduce (list :decimal-point #\,)) + +(defrule data-division-content + := file-section? working-storage-section? linkage-section?) + +(defrule file-section-entry + := file-and-sort-description-entry data-description-entry+ + :reduce (cons file-and-sort-description-entry data-description-entry)) + +(defrule file-section-head + := "FILE" "SECTION" ".") + +(defrule file-section + := file-section-head file-section-entry* + :reduce $2) + +(defrule working-storage-section-head + := "WORKING-STORAGE" "SECTION" ".") + +(defrule working-storage-section + := working-storage-section-head data-description-entry* + :reduce $2) + +(defrule linkage-section-head + := "LINKAGE" "SECTION" ".") + +(defrule linkage-section + := linkage-section-head data-description-entry* + :reduce $2) + +(defrule file-and-sort-description-entry + := alt-fd-sd file-name file-and-sort-description-entry-clause* "." + :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause)) + +(defrule alt-fd-sd + := "FD" + := "SD") + +(defrule file-and-sort-description-entry-clause + := external-clause + := global-clause + := block-contains-clause + := record-clause + := label-records-clause + := value-of-clause + := data-records-clause + := linage-clause + := recording-mode-clause + := code-set-clause) + +(defrule integer-to + := integer "TO") + +(defrule block-contains-clause + := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?) + +(defrule alt-characters-records + := "CHARACTERS" + := "RECORDS" + := "RECORD") + +(defrule record-clause + := "RECORD" record-clause-tail) + +(defrule depending-on + := "DEPENDING" "ON"? data-name) + +(defrule record-clause-tail-1 + := "CONTAINS"? integer "CHARACTERS"?) + +(defrule record-clause-tail-2 + := "CONTAINS"? integer "TO" integer "CHARACTERS"?) + +(defrule record-clause-tail-3 + := record-varying-phrase depending-on?) + +(defrule record-clause-tail + := record-clause-tail-2 + := record-clause-tail-1 + := record-clause-tail-3) + +(defrule record-varying-phrase + := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?) + +(defrule from-integer + := "FROM"? integer) + +(defrule to-integer + := "TO" integer) + +(defrule label-records-clause + := "LABEL" records-are label-records-clause-tail + :reduce (list :label-record label-records-clause-tail)) + +(defrule data-names + := data-name+) + +(defrule label-records-clause-tail + := "STANDARD" :reduce :standard + := "OMITTED" :reduce :omitted + := data-names) + +(defrule value-of-clause + := "VALUE" "OF" value-of-clause-tail+) + +(defrule alt-qualified-data-name-literal + := qualified-data-name + := literal) + +(defrule value-of-clause-tail + := variable-identifier "IS"? alt-qualified-data-name-literal) + +(defrule data-records-clause + := "DATA" records-are data-name+) + +(defrule records-are + := records are?) + +(defrule linage-clause + := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase) + +(defrule linage-footing-phrase + := footing? lines-top? lines-bottom?) + +(defrule alt-data-name-integer + := data-name + := integer) + +(defrule footing + := "WITH"? "FOOTING" "AT"? alt-data-name-integer) + +(defrule lines-top + := "LINES"? "AT"? "TOP" alt-data-name-integer) + +(defrule lines-bottom + := "LINES"? "AT"? "BOTTOM" alt-data-name-integer) + +(defrule recording-mode-clause + := "RECORDING" "MODE"? "IS"? variable-identifier) + +(defrule code-set-clause + := "CODE-SET" "IS"? alphabet-name) + +(defrule data-description-entry + := level-number alt-data-name-filler? data-description-entry-clause* "." + :reduce (append (list level-number alt-data-name-filler) + (flatten-list data-description-entry-clause))) + +(defrule alt-data-name-filler + := data-name + := "FILLER" + :reduce (list)) + +(defrule data-description-entry-clause + := picture-clause + := redefines-clause + := blank-when-zero-clause + := external-clause + := global-clause + := justified-clause + := occurs-clause + := sign-clause + := synchronized-clause + := usage-clause + := renames-clause + := value-clause) + +(defrule value-clause + := "VALUE" "IS"? literal + :reduce (list :value literal)) + +(defrule redefines-clause + := "REDEFINES" data-name + :reduce `(:redefines ,data-name)) + +(defrule blank-when-zero-clause + := "BLANK" "WHEN"? zeroes + :reduce '(:blank-when-zero t)) + +(defrule zeroes + := "ZERO" + := "ZEROS" + := "ZEROES") + +(defrule external-clause + := "IS"? "EXTERNAL" + :reduce '(:external t)) + +(defrule global-clause + := "IS"? "GLOBAL" + :reduce '(:global t)) + +(defrule justified-clause + := justified "RIGHT"? + :reduce `(:justified ,(if $2 :right :left))) + +(defrule justified + := "JUSTIFIED" + := "JUST") + +(defrule occurs-clause + := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times ,integer) + := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times (,integer ,integer2 ,qualified-data-name))) + +(defrule occurs-clause-key + := alt-ascending-descending "KEY"? "IS"? qualified-data-name+) + +(defrule indexed-by + := "INDEXED" "BY"? index-name+) + +(defrule picture-clause + := picture "IS"? picture-string + :reduce `(:picture ,picture-string)) + +(defrule picture + := "PICTURE" + := "PIC") + +(defrule sign-clause + := sign-is? alt-leading-trailing separate-character? + :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing)) + +(defrule sign-is + := "SIGN" "IS"?) + +(defrule separate-character + := "SEPARATE" "CHARACTER"? + :reduce t) + +(defrule alt-leading-trailing + := "LEADING" + :reduce :leading + := "TRAILING" + :reduce :trailing) + +(defrule synchronized-clause + := synchronized alt-left-right? + :reduce `(:synchronized ,(if alt-left-right + alt-left-right + t))) + +(defrule alt-left-right + := "LEFT" + :reduce :left + := "RIGHT" + :reduce :right) + +(defrule synchronized + := "SYNCHRONIZED" + := "SYNC") + +(defrule usage-clause + := usage-is? usage + :reduce (list :encoding usage)) + +(defrule usage-is + := "USAGE" "IS"?) + +(defrule usage + := "BINARY" + :reduce :binary + := "COMP" + :reduce :comp + := "COMP-1" + :reduce :comp1 + := "COMP-2" + :reduce :comp2 + := "COMP-3" + :reduce :comp3 + := "COMP-4" + :reduce :comp4 + := "COMPUTATIONAL" + :reduce :comp + := "COMPUTATIONAL-1" + :reduce :comp1 + := "COMPUTATIONAL-2" + :reduce :comp2 + := "COMPUTATIONAL-3" + :reduce :comp3 + := "COMPUTATIONAL-4" + :reduce :comp4 + := "DISPLAY" + :reduce :display + := "DISPLAY-1" + :reduce :display1 + := "INDEX" + :reduce :index + := "PACKED-DECIMAL" + :reduce :packed-decimal + := "POINTER" + :reduce :pointer) + +(defrule renames-clause + := "RENAMES" qualified-data-name through-qualified-data-name? + :reduce `(:renames ,qualified-data-name ,through-qualified-data-name)) + +(defrule through-qualified-data-name + := through qualified-data-name + :reduce qualified-data-name) + +(defrule condition-value-clause + := values-are literal-through-literal+) + +(defrule through-literal + := through literal) + +(defrule literal-through-literal + := literal through-literal?) + +(defrule values-are + := values are?) + +(defrule procedure-division-head + := "PROCEDURE" "DIVISION" using-phrase? ".") + +(defrule procedure-division + := procedure-division-head sentence+) + +(defrule using-phrase + := "USING" data-name+) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule declaratives + := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".") + +(defrule declaratives-content + := cobol-identifier "SECTION" "." use-statement "." sentence*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule paragraph-header + := cobol-identifier "SECTION"? + :reduce (list (if $2 :section :label) $1)) + +(defrule sentence + := declaratives + := statement* "." + :reduce $1 + := paragraph-header "." + :reduce $1) + +(defrule statement + := move-statement + := if-statement + := perform-statement + := go-to-statement + := accept-statement + := add-statement + := alter-statement + := call-statement + := cancel-statement + := close-statement + := compute-statement + := continue-statement + := delete-statement + := display-statement + := divide-statement + := entry-statement + := evaluate-statement + := exit-program-statement + := exit-statement + := goback-statement + := initialize-statement + := inspect-statement + := merge-statement + := multiply-statement + := open-statement + := read-statement + := release-statement + := return-statement + := rewrite-statement + := search-statement + := set-statement + := sort-statement + := start-statement + := stop-statement + := string-statement + := subtract-statement + := unstring-statement + := write-statement + := paragraph-header) + +(defrule accept-statement + := "ACCEPT" variable-identifier "FROM" date + := "ACCEPT" variable-identifier "AT" screen-coordinates + :reduce (apply #'list 'accept-at variable-identifier screen-coordinates) + := "ACCEPT" variable-identifier from-environment-name?) + +(defrule from-environment-name + := "FROM" cobol-identifier) + + +(defrule date + := "DATE" + := "DAY" + := "DAY-OF-WEEK" + := "TIME") + +(defrule add-statement + := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?) + +(defrule statement-list + := statement+) + +(defrule alter-statement + := "ALTER" procedure-to-procedure+) + +(defrule proceed-to + := "PROCEED" "TO") + +(defrule procedure-to-procedure + := procedure-name "TO" proceed-to? procedure-name) + +(defrule call-statement + := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"? + :reduce (list 'call id-or-lit (cons 'list using-parameters))) + +(defrule by-reference + := "BY"? "REFERENCE") + +(defrule content-parameter-value + := cobol-identifier + := literal) + +(defrule reference-parameter + := by-reference? variable-identifier) + +(defrule content-parameter + := "BY"? "CONTENT" content-parameter-value+) + +(defrule parameter + := reference-parameter + := content-parameter + := literal) + +(defrule using-parameters + := "USING" parameter+) + +(defrule call-rest-phrase + := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?) + +(defrule on-exception-statement-list + := "ON"? "EXCEPTION" statement-list) + +(defrule not-on-exception-statement-list + := "NOT" "ON"? "EXCEPTION" statement-list) + +(defrule cancel-statement + := "CANCEL" id-or-lit+) + +(defrule close-statement + := "CLOSE" close-statement-file-name+ + :reduce (list 'close close-statement-file-name)) + +(defrule alt-removal-no-rewind + := for-removal + := with-no-rewind) + +(defrule alt-reel-unit + := "REEL" + := "UNIT") + +(defrule alt-no-rewind-lock + := no-rewind + := "LOCK") + +(defrule close-statement-options-1 + := alt-reel-unit alt-removal-no-rewind?) + +(defrule close-statement-options-2 + := "WITH"? alt-no-rewind-lock) + +(defrule close-statement-options + := close-statement-options-1 + := close-statement-options-2) + +(defrule close-statement-file-name + := file-name close-statement-options?) + +(defrule compute-statement + := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"? + :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule equal + := "=" + := "EQUAL") + +(defrule continue-statement + := "CONTINUE") + +(defrule delete-statement + := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"? + :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list)) + +(defrule display-statement + := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing? + :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing)) + := "DISPLAY" id-or-lit "AT" screen-coordinates + :reduce (apply #'list 'display-at id-or-lit screen-coordinates)) + +(defrule screen-coordinates + := integer + :reduce (multiple-value-list (truncate integer 100))) + +(defrule upon-environment-name + := "UPON" cobol-identifier) + +(defrule with-no-advancing + := "WITH"? "NO" "ADVANCING") + +(defrule divide-statement + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?) + +(defrule entry-statement + := "ENTRY" literal using-phrase?) + +(defrule evaluate-statement + := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?) + +(defrule evaluate-condition + := condition + := "TRUE" + := "FALSE") + +(defrule also-phrase + := "ALSO" evaluate-condition) + +(defrule when-phrase-also-phrase + := "ALSO" evaluate-phrase) + +(defrule when-phrase + := "WHEN" evaluate-phrase when-phrase-also-phrase*) + +(defrule when-phrases + := when-phrase+ statement-list) + +(defrule when-other-phrase + := "WHEN" "OTHER" statement-list) + +(defrule evaluate-phrase + := "ANY" + := condition + := "TRUE" + := "FALSE" + := evaluate-phrase-1) + +(defrule evaluate-phrase-1 + := "NOT"? arithmetic-expression through-arithmetic-expression?) + +(defrule through-arithmetic-expression + := through arithmetic-expression) + +(defrule exit-statement + := "EXIT" + :reduce '(exit-paragraph)) + +(defrule exit-program-statement + := "EXIT" "PROGRAM" + :reduce '(exit-program)) + +(defrule goback-statement + := "GOBACK" + :reduce '(go-back)) + +(defrule go-to-statement + := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier + :reduce (list 'goto-depending variable-identifier procedure-name) + := "GO" "TO"? procedure-name + :reduce (list 'goto procedure-name)) + +(defrule if-phrase + := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence + :reduce (list 'if condition + (if (cdr alt-statement-list-next-sentence) + (cons 'progn alt-statement-list-next-sentence) + (car alt-statement-list-next-sentence)) + (if (cdr alt-statement-list-next-sentence2) + (cons 'progn alt-statement-list-next-sentence2) + (car alt-statement-list-next-sentence2))) + := "IF" condition "THEN"? alt-statement-list-next-sentence + :reduce (append (list 'when condition) alt-statement-list-next-sentence)) + +(defrule if-statement + := if-phrase "END-IF"? + :reduce $1) + +(defrule initialize-statement + := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?) + +(defrule initialize-replacing-type + := "ALPHABETIC" + := "ALPHANUMERIC" + := "NUMERIC" + := "ALPHANUMERIC-EDITED" + := "NUMERIC-EDITED" + := "DBCS" + := "EGCS") + +(defrule initialize-replacing-argument + := initialize-replacing-type "DATA"? "BY" id-or-lit) + +(defrule initialize-replacing-phrase + := "REPLACING" initialize-replacing-argument+) + +(defrule inspect-statement + := inspect-statement-1 + := inspect-statement-2 + := inspect-statement-3 + := inspect-statement-4) + +(defrule inspect-statement-1 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+) + +(defrule inspect-statement-2 + := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*) + +(defrule inspect-statement-3 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+) + +(defrule tallying-for-id-or-lit + := id-or-lit before-after-phrase*) + +(defrule alt-all-leading + := "ALL" + := "LEADING") + +(defrule tallying-for-argument-1 + := "CHARACTERS" before-after-phrase*) + +(defrule tallying-for-argument-2 + := alt-all-leading tallying-for-id-or-lit+) + +(defrule tallying-for-argument + := tallying-for-argument-1 + := tallying-for-argument-2) + +(defrule tallying-argument + := variable-identifier "FOR" tallying-for-argument+) + +(defrule inspect-statement-4 + := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+) + +(defrule inspect-replacing-argument + := inspect-by-argument "BY" inspect-by-argument before-after-phrase*) + +(defrule alt-all-leading-first + := "ALL" + := "LEADING" + := "FIRST") + +(defrule inspect-replacing-phrase-1 + := "CHARACTERS" "BY" id-or-lit before-after-phrase*) + +(defrule inspect-replacing-phrase-2 + := alt-all-leading-first inspect-replacing-argument+) + +(defrule inspect-replacing-phrase + := inspect-replacing-phrase-1 + := inspect-replacing-phrase-2) + +(defrule before-after-phrase + := alt-before-after "INITIAL"? id-or-lit) + +(defrule merge-statement + := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail) + +(defrule on-key-phrase + := "ON"? alt-ascending-descending "KEY"? qualified-data-name+) + +(defrule merge-statement-tail + := output-procedure + := giving-file-names) + +(defrule move-statement + := "MOVE" id-or-lit "TO" variable-identifier+ + :reduce (apply #'list 'move id-or-lit variable-identifier) + := "MOVE" corresponding variable-identifier "TO" variable-identifier+ + :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2)) + +(defrule multiply-statement + := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule open-statement + := "OPEN" open-statement-phrase+ + :reduce (list 'open open-statement-phrase)) + +(defrule alt-reversed-with-no-rewind + := "REVERSED" + := with-no-rewind) + +(defrule open-statement-input-file-name + := file-name alt-reversed-with-no-rewind?) + +(defrule with-no-rewind + := "WITH"? "NO" "REWIND") + +(defrule open-statement-output-file-name + := file-name with-no-rewind?) + +(defrule open-statement-input + := "INPUT" open-statement-input-file-name+) + +(defrule open-statement-output + := "OUTPUT" open-statement-output-file-name+) + +(defrule open-statement-i-o + := "I-O" file-name+) + +(defrule open-statement-extend + := "EXTEND" file-name+) + +(defrule open-statement-phrase + := open-statement-input + := open-statement-output + := open-statement-i-o + := open-statement-extend) + +(defrule perform-statement + := "PERFORM" procedure-name through-procedure-name? perform-until-phrase + :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase) + := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase* + :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase) + := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES" + :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name) + := "PERFORM" procedure-name through-procedure-name? + :reduce (append (list 'perform procedure-name) through-procedure-name)) + +(defrule perform-varying-phrase + := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-after-phrase + := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-until-phrase + := with-test? "UNTIL" condition) + +(defrule with-test + := "WITH"? "TEST" alt-before-after + :reduce alt-before-after) + +(defrule read-statement + := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?) + +(defrule key-is-qualified-data-name + := "KEY" "IS"? qualified-data-name) + +(defrule release-statement + := "RELEASE" record-name from-identifier?) + +(defrule return-statement + := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?) + +(defrule into-identifier + := "INTO" variable-identifier) + +(defrule not-at-end-statement-list + := "NOT" "AT"? "END" statement-list) + +(defrule rewrite-statement + := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?) + +(defrule search-statement + := search-statement-1 + := search-statement-2) + +(defrule search-statement-1 + := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?) + +(defrule varying-identifier + := "VARYING" variable-identifier) + +(defrule when-condition-stats + := "WHEN" condition alt-statement-list-next-sentence) + +(defrule search-statement-2 + := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?) + +(defrule at-end-statement-list + := "AT"? "END" statement-list) + +(defrule search-statement-equal-expression + := variable-identifier "IS"? equal-to arithmetic-expression + :reduce (list '= variable-identifier arithmetic-expression)) + +(defrule search-statement-condition + := search-statement-equal-expression + := condition-name-reference) + +(defrule search-statement-condition-tail + := "AND" search-statement-condition) + +(defrule alt-statement-list-next-sentence + := statement+ + := next-sentence + :reduce :next-sentence) + +(defrule set-statement + := "SET" set-statement-phrase+) + +(defrule sort-statement + := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out) + +(defrule key-is + := "KEY" "IS"?) + +(defrule alt-ascending-descending + := "ASCENDING" + := "DESCENDING") + +(defrule on-key-is-phrase + := "ON"? alt-ascending-descending key-is? qualified-data-name+) + +(defrule with-duplicates-in-order + := "WITH"? "DUPLICATES" "IN"? "ORDER"?) + +(defrule collating-sequence + := "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule through + := "THROUGH" + := "THRU") + +(defrule through-procedure-name + := through procedure-name + :reduce procedure-name) + +(defrule using-file-names + := "USING" file-name+) + +(defrule input-procedure + := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule giving-file-names + := "GIVING" file-name+) + +(defrule output-procedure + := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule sort-statement-in + := using-file-names + := input-procedure) + +(defrule sort-statement-out + := giving-file-names + := output-procedure) + +(defrule start-statement + := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?) + +(defrule rel-op + := equal-to + :reduce '= + := greater-than + :reduce '> + := greater-equal + :reduce '>=) + +(defrule key-is-rel-op-qualified-data-name + := "KEY" "IS"? rel-op qualified-data-name + :reduce (list rel-op qualified-data-name)) + +(defrule stop-statement + := "STOP" alt-run-literal + :reduce '(stop)) + +(defrule alt-run-literal + := "RUN" + := literal) + +(defrule string-statement + := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"? + :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit-size + := literal + := variable-identifier + := "SIZE") + +(defrule delimited-by-phrase + := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size + :reduce (list id-or-lit id-or-lit-size)) + +(defrule subtract-statement + := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract id-or-lit cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-corr variable-identifier variable-identifier + :rounded (and $5 t) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule cobword-rounded + := variable-identifier "ROUNDED"? + :reduce (list variable-identifier (and $2 t))) + +(defrule on-size-error-statement-list + := "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule not-on-size-error-statement-list + := "NOT" "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule corresponding + := "CORRESPONDING" + := "CORR") + +(defrule unstring-statement + := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"? + :reduce (list 'unstring variable-identifier unstring-statement-dst + :delimited-by-all delimited-by-all-phrase + :with-pointer with-pointer-identifier + :tallying tallying-in-identifier + :on-overflow on-overflow-statement-list + :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit + := literal + := variable-identifier) + +(defrule or-all-id-or-lit + := "OR" "ALL"? id-or-lit) + +(defrule delimited-by-all-phrase + := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*) + +(defrule delimiter-in-identifier + := "DELIMITER" "IN"? variable-identifier) + +(defrule count-in-identifier + := "COUNT" "IN"? variable-identifier) + +(defrule unstring-statement-dst + := variable-identifier delimiter-in-identifier? count-in-identifier?) + +(defrule with-pointer-identifier + := "WITH"? "POINTER" variable-identifier) + +(defrule tallying-in-identifier + := "TALLYING" "IN"? variable-identifier) + +(defrule on-overflow-statement-list + := "ON"? "OVERFLOW" statement-list) + +(defrule not-on-overflow-statement-list + := "NOT" "ON"? "OVERFLOW" statement-list) + +(defrule write-statement + := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?) + +(defrule lines + := "LINE" + := "LINES") + +(defrule cobword-int + := cobol-identifier + := integer) + +(defrule nr-lines-phrase + := cobword-int lines?) + +(defrule page-phrase + := nr-lines-phrase + := "PAGE") + +(defrule alt-before-after + := "BEFORE" + := "AFTER") + +(defrule advancing-phrase + := alt-before-after "ADVANCING"? page-phrase) + +(defrule from-identifier + := "FROM" variable-identifier) + +(defrule invalid-key-statement-list + := "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule not-invalid-key-statement-list + := "NOT" "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule end-of-page + := "END-OF-PAGE" + := "EOP") + +(defrule at-end-of-page-statement-list + := "AT"? end-of-page statement-list + :reduce statement-list) + +(defrule not-at-end-of-page-statement-list + := "NOT" "AT"? end-of-page statement-list + :reduce statement-list) + +;; This is left in the grammar but is not used. COPYs are handled by +;; the lexical scanner. +(defrule copy-statement + := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?) + +(defrule in + := "OF" + := "IN") + +(defrule alt-library-name-literal + := library-name + := literal) + +(defrule in-library + := in alt-library-name-literal) + +(defrule copy-statement-by-phrase + := copy-operand "BY" copy-operand) + +(defrule copy-statement-replacing-phrase + := "REPLACING" copy-statement-by-phrase+) + +(defrule alt-text-name-literal + := text-name + := literal) + +(defrule copy-operand + := cobol-identifier + := literal) + +(defrule use-statement + := use-statement-1 + := use-statement-2 + := use-statement-3) + +(defrule use-statement-1 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-exception-error + := "EXCEPTION" + := "ERROR") + +(defrule use-statement-2 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-beginning-ending + := "BEGINNING" + := "ENDING") + +(defrule alt-file-reel-unit + := "FILE" + := "REEL" + := "UNIT") + +(defrule file-names + := file-name+) + +(defrule alt-file-names-i-o + := file-names + := "INPUT" + := "OUTPUT" + := "I-O" + := "EXTEND") + +(defrule use-statement-3 + := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures) + +(defrule procedure-names + := procedure-name+) + +(defrule alt-procedures-all-procedures + := procedure-names + := all-procedures) + +(defrule condition + := combinable-condition + := combinable-condition "AND" condition + :reduce `(and ,combinable-condition ,condition) + := combinable-condition "OR" condition + :reduce `(or ,combinable-condition ,condition) + := combinable-condition "AND" id-or-lit + :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)) + := combinable-condition "OR" id-or-lit + :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))) + +(defrule combinable-condition + := "NOT"? simple-condition + :reduce (if $1 + (list 'not simple-condition) + simple-condition)) + +(defrule simple-condition + := class-condition + := relation-condition + := sign-condition + := "(" condition ")" + ;; not sure if it's necessary -wcp15/7/03. + ;; := arithmetic-expression + ) + +(defrule class-condition + := variable-identifier "IS"? "NOT"? class-type + :reduce (if $3 + (list 'not (list 'type-of variable-identifier (make-keyword class-type))) + (list 'type-of variable-identifier (make-keyword class-type)))) + +(defrule class-type + := "NUMERIC" + := "ALPHABETIC" + := "ALPHABETIC-LOWER" + := "ALPHABETIC-UPPER" + := "DBCS") + +(defun unfold-subrelations (main-relation subs) + (destructuring-bind (main-operator main-variable other-variable) main-relation + (declare (ignore other-variable)) + (labels ((unfold (subs) + (if (null subs) + main-relation + (destructuring-bind (connection operator variable) (car subs) + (list connection + (list (or operator main-operator) main-variable variable) + (unfold (cdr subs))))))) + (unfold subs)))) + +(defrule relation-condition + ;; This is too complex + ;; := arithmetic-expression relational-operator simple-condition + := id-or-lit relational-operator id-or-lit subordinate-relation* + :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation)) + +(defrule or-and + := "OR" :reduce 'or + := "AND" :reduce 'and) + +(defrule subordinate-relation + := or-and relational-operator? id-or-lit + :reduce (list or-and relational-operator id-or-lit)) + +(defrule relational-operator + := "IS"? relational-operator-type + :reduce relational-operator-type) + +(defrule less-than + := "LESS" "THAN"? + := "<") + +(defrule greater-equal + := "GREATER" "THAN"? "OR" "EQUAL" "TO"? + := ">=" + := ">" "=" + := "NOT" "<" + := "NOT" "LESS" "THAN"?) + +(defrule less-equal + := "LESS" "THAN"? "OR" "EQUAL" "TO"? + := "<=" + := "<" "=" + := "NOT" ">" + := "NOT" "GREATER" "THAN"?) + +(defrule greater-than + := "GREATER" "THAN"? + := ">") + +(defrule equal-to + := "EQUAL" "TO"? + := "=") + +(defrule relational-operator-type + := greater-equal + :reduce 'cob>= + := less-equal + :reduce 'cob<= + := greater-than + :reduce 'cob> + := less-than + :reduce 'cob< + := equal-to + :reduce 'cob= + := "NOT" equal-to + :reduce 'cob-not=) + +(defrule sign-condition + := arithmetic-expression "IS"? "NOT"? sign-type + :reduce (if $3 + `(not (,sign-type ,arithmetic-expression)) + `(,sign-type ,arithmetic-expression))) + +(defrule sign-type + := "POSITIVE" :reduce '> + := "NEGATIVE" :reduce '< + := "ZERO" :reduce '= + := "ZEROES" :reduce '= + := "ZEROS" :reduce '=) + +(defrule procedure-name + := paragraph-or-section-name in-section-name + :reduce (list paragraph-or-section-name in-section-name) + := paragraph-or-section-name + :reduce paragraph-or-section-name) + +(defrule in-section-name + := in cobol-identifier + :reduce cobol-identifier) + +(defrule variable-identifier + := qualified-data-name subscript-parentheses* ;; reference-modification? + :reduce (if subscript-parentheses + (list :aref qualified-data-name subscript-parentheses) + qualified-data-name)) + +(defrule reference-modification + := "(" leftmost-character-position ":" length? ")" + :reduce (if length + (list :range leftmost-character-position length) + leftmost-character-position)) + +(defrule condition-name-reference + := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*) + +(defrule in-data-or-file-or-mnemonic-name + := in data-or-file-or-mnemonic-name) + +(defrule subscript-parentheses + := "(" subscript ")") + +(defrule subscript + := subscript-expression+) + +(defrule plus-minus-integer + := plus-or-minus integer) + +(defrule subscript-expression-ambiguous + := qualified-data-name plus-minus-integer?) + +(defrule subscript-expression + := literal + := subscript-expression-ambiguous) + +(defrule qualified-data-name + := data-name in-data-or-file-name* + :reduce (if in-data-or-file-name + (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. + data-name) + := "ADDRESS" "OF" data-name + :reduce (list 'address-of data-name) + := "LENGTH" "OF" cobol-identifier + :reduce (list 'length-of cobol-identifier)) + +(defrule in-data-or-file-name + := in data-or-file-name) + +(defrule leftmost-character-position + := arithmetic-expression) + +(defrule length + := arithmetic-expression) + +(defrule arithmetic-expression + := times-div + := times-div "+" arithmetic-expression + :reduce `(+ ,times-div ,arithmetic-expression) + := times-div "-" arithmetic-expression + :reduce `(- ,times-div ,arithmetic-expression)) + +(defrule times-div + := power + := power "*" times-div + :reduce `(* ,power ,times-div) + := power "/" times-div + :reduce `(/ ,power ,times-div)) + +(defrule power + := plus-or-minus? basis + := plus-or-minus? basis "**" power + :reduce (if plus-or-minus + `(plus-or-minus (expt basis basis2)) + `(expt basis basis2))) + +(defrule plus-or-minus + := "+" + :reduce '+ + := "-" + :reduce '-) + +;; (defrule power-tail +;; := "**" basis) + +(defrule basis + := literal + := variable-identifier + := "(" arithmetic-expression ")") + +(defrule alphabet-name + := cobol-identifier) + +(defrule condition-name + := cobol-identifier) + +(defrule data-name + := cobol-identifier) + +(defrule cobol-identifier + := identifier + :reduce (intern (string-upcase identifier))) + +(defrule file-name + := cobol-identifier) + +(defrule data-or-file-name + := cobol-identifier) + +(defrule index-name + := cobol-identifier) + +(defrule mnemonic-name + := cobol-identifier) + +(defrule data-or-file-or-mnemonic-name + := cobol-identifier) + +(defrule record-name + := qualified-data-name) + +(defrule symbolic-character + := cobol-identifier) + +(defrule library-name + := cobol-identifier) + +(defrule program-name + := cobol-identifier + := string) + +(defrule text-name + := cobol-identifier) + +(defrule paragraph-or-section-name + := cobol-identifier + := integer) + +(defrule computer-name + := identifier) + +(defrule environment-name + := cobol-identifier) + +(defrule assignment-name + := cobol-identifier) + +(defrule figurative-constant + := figurative-constant-simple + := figurative-constant-all) + +(defrule figurative-constant-all + := "ALL" literal) + +(defrule literal + := string + := float + := integer + := figurative-constant) + +) ; defun populate-grammar diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd new file mode 100644 index 0000000000..1e35186d6c --- /dev/null +++ b/third_party/lisp/npg/npg.asd @@ -0,0 +1,55 @@ +;;; npg.asd --- declaration of this system + +;;; Copyright (C) 2003, 2006 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: npg.asd, Time-stamp: <2006-01-03 17:20:21 wcp> $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :npg-system + (:use :common-lisp :asdf)) + +(in-package :npg-system) + +(defclass sample-file (doc-file) ()) +(defmethod source-file-type ((c sample-file) (s module)) + "lisp") + +(defsystem npg + :name "NPG" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :licence "Lesser General Public License" + :description "NPG a Naive Parser Generator" + :long-description + "NPG is a backtracking recursive descent parser generator for +Common Lisp. It accepts rules in a Lispy EBNF syntax without indirect +left recursive rules." + :components + ((:doc-file "README") + (:doc-file "COPYING") + (:doc-file ".project") + (:module :examples + :components + ((:sample-file "python") + (:sample-file "vs-cobol-ii"))) + (:module :src + :components + ((:file "package") + (:file "common" :depends-on ("package")) + (:file "define" :depends-on ("package" "common")) + (:file "parser" :depends-on ("package" "common")))))) diff --git a/third_party/lisp/npg/src/common.lisp b/third_party/lisp/npg/src/common.lisp new file mode 100644 index 0000000000..8b64f5cc0a --- /dev/null +++ b/third_party/lisp/npg/src/common.lisp @@ -0,0 +1,79 @@ +;;; common.lisp --- common stuff + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: common.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +(eval-when (:compile-toplevel :load-toplevel) + (defstruct grammar + rules + keywords + equal-p) + + (defstruct rule + name + productions) + + (defstruct (production (:conc-name prod-)) + tokens + (tokens-length 0 :type fixnum) + action) + + (defstruct token + type ; type of token (identifier, number, ...) + value ; its actual value + position) ; line/column in the input stream + ) ; eval-when + +(defmethod print-object ((obj rule) stream) + (format stream "#R(~A)" (rule-name obj))) + +(defmethod print-object ((obj production) stream) + (format stream "#P(action: ~S)" (prod-action obj))) + +(defmethod print-object ((obj token) stream) + (format stream "#T:~A=~S" (token-type obj) (token-value obj))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-rules-table find-rule add-rule)) + +(defun make-rules-table () + (make-hash-table)) + +(defun find-rule (rule-name rules) + (gethash rule-name rules)) + +(defun add-rule (rule-name rule rules) + (setf (gethash rule-name rules) rule)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-keywords-table find-keyword add-keyword)) + +(defun make-keywords-table () + (make-hash-table :test 'equal)) + +(defun find-keyword (keyword-name keywords) + (gethash keyword-name keywords)) + +(defun add-keyword (keyword keywords) + (setf (gethash keyword keywords) t)) diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp new file mode 100644 index 0000000000..783f071fc5 --- /dev/null +++ b/third_party/lisp/npg/src/define.lisp @@ -0,0 +1,408 @@ +;;; define.lisp --- grammar rules definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: define.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *smart-default-reduction* t + "If true the default reductions take only the non-static tokens - +those that are not declared as strings in the grammar.") + +;; These two are filled with DEFRULE. +(defvar *rules* (make-rules-table)) +(defvar *keywords* (make-keywords-table)) + +(defun make-action-arguments (tokens) + "Given a list of tokens making up a production, return three values: +the list of variables for the function reducing this production, those +that are non static and their unambiguous user-friendly names." + (flet ((unique (sym list) + (if (not (assoc sym list)) + sym + (loop + for i of-type fixnum from 2 + for x = (intern (format nil "~:@(~A~)~A" sym i)) + while (assoc x list) + finally (return x))))) + (loop + for tok in tokens + for i of-type fixnum from 1 + for arg = (intern (format nil "$~A" i) (find-package #.*package*)) + collect arg into args + unless (const-terminal-p tok) + collect arg into vars + and when (symbolp tok) + collect (list (unique tok named-vars) arg) into named-vars + when (and (listp tok) + (symbolp (cadr tok))) + collect (list (unique (cadr tok) named-vars) arg) into named-vars + finally + (return (values args vars named-vars))))) + +(defun make-action-function (name tokens action) + "Create a function with name NAME, arguments derived from TOKENS and +body ACTION. Return it's definition." + (let ((function + (multiple-value-bind (args vars named-vars) + (make-action-arguments tokens) + `(lambda ,args + (declare (ignorable ,@args)) + (let (($vars (list ,@vars)) + ($all (list ,@args)) + ,@named-vars + ($alist (list ,@(mapcar #'(lambda (v) + `(cons ',(intern (symbol-name (car v))) + ,(cadr v))) + named-vars)))) + (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) + (flet ((make-object (&optional type args) + (apply #'make-instance (or type ',name) + (append args $alist)))) + ,action)))))) + (when *compile-print* + (if *compile-verbose* + (format t "; Compiling ~S:~% ~S~%" name function) + (format t "; Compiling ~S~%" name))) + (compile name function))) + +(defun define-rule (name productions) + "Accept a rule in EBNF-like syntax, translate it into a sexp and a +call to INSERT-RULE-IN-CURRENT-GRAMMAR." + (flet ((transform (productions) + (loop + for tok in productions + with prod = nil + with action = nil + with phase = nil + with new-prods = nil + while tok + do (cond ((eq tok :=) + (push (list (nreverse prod) action) new-prods) + (setf prod nil + action nil + phase :prod)) + ((eq tok :reduce) + (setf phase :action)) + ((eq tok :tag) + (setf phase :tag)) + ((eq phase :tag) + (setf action `(cons ,tok $vars))) + ((eq phase :action) + (setf action tok)) + ((eq phase :prod) + (push tok prod))) + finally + (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) + (insert-rule-in-current-grammar name (transform productions)))) + +(defmacro defrule (name &rest productions) + "Wrapper macro for DEFINE-RULE." + `(define-rule ',name ',productions)) + +(defun make-optional-rule (token) + "Make a rule for a possibly missing (non)terminal (? syntax) and +return it." + (insert-rule-in-current-grammar + (gensym (concatenate 'string "OPT-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))) + `(((,token)) (())))) + +(defun make-alternative-rule (tokens) + "Make a rule for a list of alternatives (\"or\" syntax) and return it." + (insert-rule-in-current-grammar + (gensym "ALT") + (mapcar #'(lambda (alternative) + `((,alternative))) + tokens))) + +(defun make-nonempty-list-rule (token &optional separator) + "Make a rule for a non-empty list (+ syntax) and return it." + (let ((rule-name (gensym (concatenate 'string "NELST-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))))) + (insert-rule-in-current-grammar + rule-name + (if separator + `(((,token ,separator ,rule-name) + (cons $1 $3)) + ((,token) ,#'list)) + `(((,token ,rule-name) + (cons $1 $2)) + ((,token) ,#'list)))))) + +(defun make-list-rule (token &optional separator) + "Make a rule for a possibly empty list (* syntax) return it." + (make-optional-rule (make-nonempty-list-rule token separator))) + +(defun const-terminal-p (object) + (or (stringp object) + (keywordp object))) + +(defun expand-production-token (tok) + "Translate token of the type NAME? or NAME* or NAME+ into (? NAME) +or (* NAME) or (+ NAME). This is used by the DEFRULE macro." + (if (symbolp tok) + (let* ((name (symbol-name tok)) + (last (char name (1- (length name)))) + ;; this looks silly but we need to make sure that we + ;; return symbols interned in this package, no one else + (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) + (if (and (> (length name) 1) op) + (list op + (intern (subseq name 0 (1- (length name))))) + tok)) + tok)) + +(defun EBNF-to-SEBNF (tokens) + "Take a production as a list of TOKENS and expand it. This turns a +EBNF syntax into a sexp-based EBNF syntax or SEBNF." + (loop + for tok in tokens + for token = (expand-production-token tok) + with new-tokens = '() + do (cond ((member token '(* + ?)) + (setf (car new-tokens) + (list token (car new-tokens)))) + (t + (push token new-tokens))) + finally (return (nreverse new-tokens)))) + +(defun SEBNF-to-BNF (tokens) + "Take a production in SEBNF (Symbolic Extended BNF) syntax and turn +it into BNF. The production is simplified but the current grammar is +populated with additional rules." + (flet ((make-complex-token-rule (tok) + (ecase (car tok) + (* (apply #'make-list-rule (cdr tok))) + (+ (apply #'make-nonempty-list-rule (cdr tok))) + (? (make-optional-rule (cadr tok))) + (or (make-alternative-rule (cdr tok)))))) + (loop + for token in tokens + with new-tokens = '() + with keywords = '() + do (cond ((listp token) + (push (make-complex-token-rule token) new-tokens)) + (t + (push token new-tokens) + (when (const-terminal-p token) + (push token keywords)))) + finally (return (values (nreverse new-tokens) keywords))))) + +(defun make-default-action-function (name tokens) + "Create a sexp to be used as default action in case one is not +supplied in the production. This is usually a quite sensible +one. That is, only the non-constant tokens are returned in a +list and in case only a variable token is available that one is +returned (not included in a list). If all the tokens are +constant, then all of them are returned in a list." + (cond ((null tokens) + ;; if the production matched the empty list (no tokens) we + ;; return always nil, that is the function LIST applied to no + ;; arguments + #'list) + ((null (cdr tokens)) + ;; if the production matches just one token we simply return + ;; that + #'identity) + (*smart-default-reduction* + ;; If we are required to be "smart" then create a function + ;; that simply returns the non static tokens of the + ;; production. If the production doesn't have nonterminal, + ;; then return all the tokens. If the production has only + ;; one argument then return that one only. + (make-action-function name tokens '(cond + ((null $vars) $all) + ((null (cdr $vars)) (car $vars)) + (t $vars)))) + (t + ;; in all the other cases we return all the token matching + ;; the production + #'list))) + +(defun make-production-from-descr (name production-description) + "Take a production NAME and its description in the form of a sexp +and return a production structure object together with a list of used +keywords." + (destructuring-bind (tokens &optional action) production-description + (let ((expanded-tokens (EBNF-to-SEBNF tokens))) + (multiple-value-bind (production-tokens keywords) + (sebnf-to-bnf expanded-tokens) + (let ((funct + (cond ((not action) + (make-default-action-function name expanded-tokens)) + ((or (listp action) + ;; the case when the action is simply to + ;; return a token (ie $2) or a constant value + (symbolp action)) + (make-action-function name expanded-tokens action)) + ((functionp action) + action) + (t ; action is a constant + #'(lambda (&rest args) + (declare (ignore args)) + action))))) + (values + ;; Make a promise instead of actually resolving the + ;; nonterminals. This avoids endless recursion. + (make-production :tokens production-tokens + :tokens-length (length production-tokens) + :action funct) + keywords)))))) + +(defun remove-immediate-left-recursivity (rule) + "Turn left recursive rules of the type + A -> A x | y +into + A -> y A2 + A2 -> x A2 | E +where E is the empty production." + (let ((name (rule-name rule)) + (productions (rule-productions rule))) + (loop + for prod in productions + for tokens = (prod-tokens prod) + ;; when immediately left recursive + when (eq (car tokens) rule) + collect prod into left-recursive + else + collect prod into non-left-recursive + finally + ;; found any left recursive production? + (when left-recursive + (warn "rule ~S is left recursive" name) + (let ((new-rule (make-rule :name (gensym "REWRITE")))) + ;; A -> y A2 + (setf (rule-productions rule) + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append tokens (list new-rule)) + :tokens-length (1+ (prod-tokens-length p)) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + (funcall f-A2 (apply action head))))))) + non-left-recursive)) + ;; A2 -> x A2 | E + (setf (rule-productions new-rule) + (append + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append (cdr tokens) (list new-rule)) + :tokens-length (prod-tokens-length p) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + #'(lambda (x) + (funcall f-A2 (apply action x head)))))))) + left-recursive) + (list + (make-production :tokens nil + :tokens-length 0 + :action #'(lambda () #'(lambda (arg) arg))))))))))) + +(defun remove-left-recursivity-from-rules (rules) + (loop + for rule being each hash-value in rules + do + ;; More to be done here. For now only the trivial immediate left + ;; recursivity is removed -wcp18/11/03. + (remove-immediate-left-recursivity rule))) + +(defun resolve-all-nonterminals (rules) + (loop + for rule being each hash-value in rules + do (loop + for production in (rule-productions rule) + do (setf (prod-tokens production) + (resolve-nonterminals (prod-tokens production) rules))))) + +(defun make-rule-productions (rule-name production-descriptions) + "Return a production object that belongs to RULE-NAME made according +to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR." + (loop + for descr in production-descriptions + for i of-type fixnum from 1 by 1 + for prod-name = (intern (format nil "~:@(~A~)-PROD~A" rule-name i)) + with productions = '() + with keywords = '() + do (progn + (multiple-value-bind (production keyws) + (make-production-from-descr prod-name descr) + (push production productions) + (setf keywords (append keyws keywords)))) + finally (return + (values (nreverse productions) keywords)))) + +(defun create-rule (name production-descriptions) + "Return a new rule object together with a list of keywords making up +the production definitions." + (multiple-value-bind (productions keywords) + (make-rule-productions name production-descriptions) + (values (make-rule :name name :productions productions) + keywords))) + +(defun insert-rule-in-current-grammar (name productions) + "Add rule to the current grammar and its keywords to the keywords +hash table. You don't want to use this directly. See DEFRULE macro +instead." + (when (find-rule name *rules*) + (error "redefining rule ~A" name)) + (multiple-value-bind (rule keywords) + (create-rule name productions) + (add-rule name rule *rules*) + (dolist (term keywords) + (add-keyword term *keywords*)) + rule)) + +(defun resolve-nonterminals (tokens rules) + "Given a list of production tokens, try to expand the nonterminal +ones with their respective rule from the the RULES pool." + (flet ((resolve-symbol (sym) + (or (find-rule sym rules) + sym))) + (mapcar #'(lambda (tok) + (if (symbolp tok) + (resolve-symbol tok) + tok)) + tokens))) + +(defun reset-grammar () + "Empty the current grammar from any existing rule." + (setf *rules* (make-rules-table) + *keywords* (make-keywords-table))) + +(defun generate-grammar (&optional (equal-p #'string-equal)) + "Return a GRAMMAR structure suitable for the PARSE function, using +the current rules. EQUAL-P, if present, is a function to be used to +match the input tokens; it defaults to STRING-EQUAL." + (resolve-all-nonterminals *rules*) + (remove-left-recursivity-from-rules *rules*) + (make-grammar :rules *rules* + :keywords *keywords* + :equal-p equal-p)) diff --git a/third_party/lisp/npg/src/package.lisp b/third_party/lisp/npg/src/package.lisp new file mode 100644 index 0000000000..b405f7b5f1 --- /dev/null +++ b/third_party/lisp/npg/src/package.lisp @@ -0,0 +1,50 @@ +;;; package.lisp --- backtracking parser package definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :naive-parser-generator + (:nicknames :npg) + (:use :common-lisp) + (:export + #:parse ; The Parser + #:reset-grammar + #:generate-grammar + #:print-grammar-figures + #:grammar-keyword-p + #:keyword + #:grammar + #:make-token + #:token-value + #:token-type + #:token-position + #:later-position + #:defrule ; to define grammars + #:deftoken ; to define a lexer + #:input-cursor-mixin + #:copy-input-cursor-slots + #:dup-input-cursor + #:read-next-tokens + #:end-of-input + #:? #:+ #:* #:or + #:$vars #:$all #:$alist + #:$1 #:$2 #:$3 #:$4 #:$5 #:$6 #:$7 #:$8 #:$9 #:$10)) diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp new file mode 100644 index 0000000000..c15d26fe39 --- /dev/null +++ b/third_party/lisp/npg/src/parser.lisp @@ -0,0 +1,234 @@ +;;; parser.lisp --- runtime parser + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: parser.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is the runtime part of the parser. The code that is +;;; responsible to execute the parser defined with the primitives +;;; found in define.lisp. + +(in-package :naive-parser-generator) + +(defvar *debug* nil + "Either nil or a stream where to write the debug informations.") +#+debug (declaim (fixnum *maximum-recursion-depth*)) +#+debug (defvar *maximum-recursion-depth* 1000 + "Maximum depth the parser is allowed to recursively call itself. +This is the only way for the parser to detect a loop in the grammar. +Tune this if your grammar is unusually complex.") + +(declaim (inline reduce-production)) +(defun reduce-production (production arguments) + "Apply PRODUCTION's action on ARGUMENTS. This has the effect of + \"reducing\" the production." + (when *debug* + (format *debug* "reducing ~S on ~S~%" production arguments)) + (flet ((safe-token-value (token) + (if (token-p token) + (token-value token) + token))) + (apply (prod-action production) (mapcar #'safe-token-value arguments)))) + +(defgeneric later-position (pos1 pos2) + (:documentation + "Compare two file postions and return true if POS1 is later than +POS2 in the input stream.")) + +;; This is meant to be overloaded in the lexer +(defmethod later-position ((pos1 integer) (pos2 integer)) + (> pos1 pos2)) + +;; this looks silly but turns out to be useful (see below) +(defmethod later-position (pos1 pos2) + (and (eq pos1 :eof) (not (eq pos2 :eof)))) + +(defgeneric read-next-tokens (tokens-source) + (:documentation "Read next token from a lexical analysed stream. The nature of +TOKENS-SOURCE is implementation dependent and any lexical analyzer is +supposed to specialise this method.")) + +;; This is the actual parser. the algorithm is pretty +;; straightforward, the execution of the reductions a bit less. Error +;; recovery is rather clumsy. + +(defun parse (grammar start tokenizer) + "Match a GRAMMAR against the list of input tokens coming from TOKENIZER. +Return the reduced values according to the nonterminal actions. Raise +an error on failure." + (declare (type grammar grammar) + (type symbol start)) + (labels + ((match-token (expected token) + (when *debug* + (format *debug* "match-token ~S ~S -> " expected token)) + (let ((res (cond ((symbolp expected) + ;; non-costant terminal (like identifiers) + (eq expected (token-type token))) + ((and (stringp expected) + (stringp (token-value token))) + ;; string costant terminal + (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) + ((functionp expected) + ;; custom equality predicate (must be able + ;; to deal with token objects) + (funcall expected token)) + ;; all the rest + (t (equal expected (token-value token)))))) + (when *debug* + (format *debug* "~Amatched~%" (if res "" "not "))) + res)) + (match (expected matched #+debug depth) + (declare (list expected matched) + #+debug (fixnum depth)) + (let ((first-expected (car expected))) + (cond #+debug ((> depth *maximum-recursion-depth*) + (error "endless recursion on ~A ~A at ~A expecting ~S" + (token-type (car matched)) (token-value (car matched)) + (token-position (car matched)) expected)) + ((eq first-expected :any) + (match (cdr expected) (cdr matched) #+debug depth)) + ;; This is a trick to obtain partial parses. When we + ;; reach this expected token we assume we succeeded + ;; the parsing and return the remaining tokens as + ;; part of the match. + ((eq first-expected :rest) + ;; we could be at the end of input so we check this + (unless (cdr matched) + (setf (cdr matched) (list :rest))) + (list nil nil)) + ((rule-p first-expected) + ;; If it's a rule, then we try to match all its + ;; productions. We return the first that succeeds. + (loop + for production in (rule-productions first-expected) + for production-tokens of-type list = (prod-tokens production) + with last-error-position = nil + with last-error = nil + for (error-position error-descr) = + (progn + (when *debug* + (format *debug* "trying to match ~A: ~S~%" + (rule-name first-expected) production-tokens)) + (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) + do (cond ((not error-position) + (return (let ((args-count (prod-tokens-length production))) + (setf (cdr matched) + (cons (reduce-production + production + (subseq (the list (cdr matched)) 0 args-count)) + (nthcdr (1+ args-count) matched))) + (list nil nil)))) + ((or (not last-error) + (later-position error-position last-error-position)) + (setf last-error-position error-position + last-error error-descr))) + ;; if everything fails return the "best" error + finally (return (list last-error-position + (if *debug* + #'(lambda () + (format nil "~A, trying to match ~A" + (funcall (the function last-error)) + (rule-name first-expected))) + last-error))))) + (t + ;; if necessary load the next tokens + (when (null (cdr matched)) + (setf (cdr matched) (read-next-tokens tokenizer))) + (cond ((and (or (null expected) (eq first-expected :eof)) + (null (cdr matched))) + ;; This point is reached only once for each complete + ;; parsing. The expected tokens and the input + ;; tokens have been exhausted at the same time. + ;; Hence we succeeded the parsing. + (setf (cdr matched) (list :eof)) + (list nil nil)) + ((null expected) + ;; Garbage at end of parsing. This may mean that we + ;; have considered a production completed too soon. + (list (token-position (car matched)) + #'(lambda () + "garbage at end of parsing"))) + ((null (cdr matched)) + ;; EOF error + (list :eof + #'(lambda () + (format nil "end of input expecting ~S" expected)))) + (t ;; normal token + (let ((first-token (cadr matched))) + (if (match-token first-expected first-token) + (match (cdr expected) (cdr matched) #+debug depth) + ;; failed: we return the error + (list (token-position first-token) + #'(lambda () + (format nil "expected ~S but got ~S ~S" + first-expected (token-type first-token) + (token-value first-token))))))))))))) + (declare (inline match-token)) + (let ((result (list :head))) + (destructuring-bind (error-position error) + (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) + (when error-position + (error "~A at ~A~%" (funcall (the function error)) error-position)) + (cadr result))))) + +(defgeneric terminals-in-grammar (grammar-or-hashtable) + (:documentation + "Find non constant terminal symbols in GRAMMAR.")) + +(defmethod terminals-in-grammar ((grammar hash-table)) + (loop + for rule being each hash-value of grammar + with terminals = '() + do (loop + for prod in (rule-productions rule) + do (loop + for tok in (prod-tokens prod) + when (symbolp tok) + do (pushnew tok terminals))) + finally (return terminals))) + +(defmethod terminals-in-grammar ((grammar grammar)) + (terminals-in-grammar (grammar-rules grammar))) + +(defun print-grammar-figures (grammar &optional (stream *standard-output*)) + (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%" + (hash-table-count (grammar-rules grammar)) + (hash-table-count (grammar-keywords grammar)) + (terminals-in-grammar (grammar-rules grammar)))) + + +(defun grammar-keyword-p (keyword grammar) + "Check if KEYWORD is part of this grammar." + (find-keyword keyword (grammar-keywords grammar))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *grammars* (make-hash-table)) + +(defun find-grammar (name) + (gethash name *grammars*)) + +(defun delete-grammar (name) + (remhash name *grammars*)) + +(defun add-grammar (name grammar) + (setf (gethash name *grammars*) grammar)) diff --git a/third_party/lisp/parse-float.nix b/third_party/lisp/parse-float.nix new file mode 100644 index 0000000000..e90824108e --- /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 0000000000..61b0b1fddb --- /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 0000000000..23c67c2d9c --- /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 0000000000..d594ff1a1c --- /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 0000000000..25e0625c20 --- /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 0000000000..af48149920 --- /dev/null +++ b/third_party/lisp/prove.nix @@ -0,0 +1,29 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.prove; +in depot.nix.buildLisp.library { + name = "prove"; + + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.cl-ansi-text + depot.third_party.lisp.cl-colors + depot.third_party.lisp.cl-ppcre + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = [ + "${src}/src/color.lisp" + "${src}/src/output.lisp" + "${src}/src/asdf.lisp" + "${src}/src/report.lisp" + "${src}/src/reporter.lisp" + "${src}/src/reporter/fiveam.lisp" + "${src}/src/reporter/list.lisp" + "${src}/src/reporter/dot.lisp" + "${src}/src/reporter/tap.lisp" + "${src}/src/suite.lisp" + "${src}/src/test.lisp" + "${src}/src/prove.lisp" + ]; +} diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix new file mode 100644 index 0000000000..f7146ba93f --- /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/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md new file mode 100644 index 0000000000..2d590a0564 --- /dev/null +++ b/third_party/lisp/quasiquote_2/README.md @@ -0,0 +1,258 @@ +quasiquote-2.0 +============== + +Why should it be hard to write macros that write other macros? +Well, it shouldn't! + +quasiquote-2.0 defines slightly different rules for quasiquotation, +that make writing macro-writing macros very smooth experience. + +NOTE: quasiquote-2.0 does horrible things to shared structure!!! +(it does a lot of COPY-TREE's, so shared-ness is destroyed). +So, it's indeed a tool to construct code (where it does not matter much if the +structure is shared or not) and not the data (or, at least, not the data with shared structure) + + +```lisp +(quasiquote-2.0:enable-quasiquote-2.0) + +(defmacro define-my-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-expand-to + ,,@body))) ; note the difference from usual way + +(define-my-macro foo (x y) + ,x ; now here injections of quotation constructs work + ,y) + +(define-my-macro bar (&body body) + ,@body) ; splicing is also easy +``` + +The "injections" in macros FOO and BAR work as naively expected, as if I had written +```lisp +(defmacro foo (x y) + `(sample-thing-to-expand-to ,x ,y)) + +(defmacro bar (&body body) + `(sample-thing-to-expand-to ,@body)) + +(macroexpand-1 '(foo a b)) + + '(SAMPLE-THING-TO-EXPAND-TO A B) + +(macroexpand-1 '(bar a b c)) + + '(SAMPLE-THING-TO-EXPAND-TO A B C) +``` + + +So, how is this effect achieved? + + +DIG, INJECT and SPLICE +------------------------- + +The transformations of backquote occur at macroexpansion-time and not at read-time. +It is totally possible not to use any special reader syntax, but just +underlying macros directly! + +At the core is a macro DIG, which expands to the code that generates the +expression according to the rules, which are roughly these: + * each DIG increases "depth" by one (hence the name) + * each INJECT or SPLICE decreases "depth" by one + * if depth is 0, evaluation is turned on + * if depth if not zero (even if it's negative!) evaluation is off + * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,` + +```lisp +;; The example using macros, without special reader syntax + +(dig ; depth is 1 here + (a b + (dig ; depth is 2 here + ((inject c) ; this inject is not evaluated, because depth is nonzero + (inject (d ;depth becomes 1 here again + (inject e) ; and this inject is evaluated, because depth becomes zero + )) + (inject 2 f) ; this inject with level specification is evaluated, because it + ; decreases depth by 2 + )))) + + +;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as +`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually +``` + + +The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads +`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM). +You can just as well type DIG's, INJECT's and SPLICE's directly, +(in particular, when writing utility functions that generate macro-generating code) +or roll your own convenient reader syntax (pull requests are welcome). + +So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same +```lisp +`(a (,b `,,c) d) + +(dig (a ((inject b) (dig (inject 2 c))) d)) +``` + +You may notice the (INJECT 2 ...) form appearing, which is described below. + + +At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@ +this behaves exactly as usual quasiquotation. + + +The optional N argument +-------------- + +All quasiquote-2.0 operators accept optional "depth" argument, +which goes before the form for human readability. + +Namely, (DIG N FORM) increases depth by N instead of one and +(INJECT N FORM) decreases depth by N instead of one. + +```lisp +(DIG 2 (INJECT 2 A)) + +; gives the same result as + +(DIG (INJECT A)) +``` + + +In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM) +and ,,,,,@FORM as (SPLICE 5 FORM) + + +More examples +------------- + +For fairly complicated example, which uses ,,,@ and OINJECT (see below), + see DEFINE-BINOP-DEFINER macro +in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp), +desire to write which was the initial impulse for this project. + + +For macro, that is not a macro-writing macro, yet benefits from +ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro +(also from CG-LLVM) + +```lisp +(defmacro joining-with-comma-space (&body body) + ;; joinl just joins strings in the list with specified string + `(joinl ", " (mapcar #'emit-text-repr + (remove-if-not #'identity `(,,@body))))) + +;; the macro can be then used uniformly over strings and lists of strings +(defun foo (x y &rest z) + (joining-with-comma-space ,x ,y ,@z)) + +(foo "a" "b" "c" "d") + ;; produces + "a, b, c, d" +``` + + +ODIG and OINJECT and OSPLICE +---------------------------- + +Sometimes you don't want DIG's macroexpansion to look further into the structure of +some INJECT or SPLICE or DIG in its subform, +if the depth does not match. In these cases you need "opaque" versions of +DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE. + +```lisp +;; here injection of B would occur +(defun foo (b) + (dig (dig (inject (a (inject b)))))) + +;; and here not, because macroexpansion does not look into OINJECT form +(defun bar (b) + (dig (dig (oinject (a (inject b)))))) + +(foo 1) + + '(DIG (INJECT (A 1))) + +(bar 1) + + '(DIG (OINJECT (A (INJECT B)))) +``` + +MACRO-INJECT and MACRO-SPLICE +----------------------------- + +Sometimes you just want to abstract-out some common injection patterns... +That is, you want macros, that expand into common injection patterns. +However, you want this only sometimes, and only in special circumstances. +So it won't do, if INJECT and SPLICE just expanded something, whenever it +turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE. + +```lisp +;; with quasiquote-2.0 syntax turned on +(defmacro inject-n-times (form n) + (make-list n :initial-element `(inject ,form))) + +(let (x 0) + `(dig (a (macro-inject (inject-n-times (incf x) 3))))) +;; yields +'(a (1 2 3)) + +;;and same with MACRO-SPLICE +(let (x 0) + `(dig (a (macro-splice (inject-n-times (incf x) 3))))) +;; yields +'(a 1 2 3) +``` + +OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE. + +Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1), +before plugging it into list. +If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL, +which expand using MACROEXPAND before injecting/splicing, respectively. +That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be +macro-form, the subform of MACRO-INJECT-ALL is not. + + +Terse syntax of the ENABLE-QUASIQUOTE-2.0 +----------------------------------------- + +Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly +every time you want this special things is kind of clumsy. For that, default reader +of quasiquote-2.0 provides extended syntax + +```lisp +',,,,!oma@x + +;; reads as +'(OMACRO-SPLICE-ALL 4 X) +``` + +That is, the regexp of the syntax is +[,]+![o][m][a][@]<whatever> + +As usual, number of commas determine the anti-depth of the injector, exclamation mark +turns on the syntax, if `o` is present, opaque version of injector will be used, +if `m` is present, macro-expanding version of injector will be used and if +`a` is present, macro-all version of injector will be used. + +Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but +this will not correspond to the actual macro name. + +Note: it was necessary to introduce special escape-char for extended syntax, +since usual idioms like `,args` would otherwise be completely screwed. + + +TODO +---- + +* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading +* wrappers for convenient definition of custom overloading schemes +* some syntax for opaque operations + +P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com + and has nothing to do with being "the 2.0" version of quasiquote. \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/default.nix b/third_party/lisp/quasiquote_2/default.nix new file mode 100644 index 0000000000..521c384787 --- /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 0000000000..6ebeb47d08 --- /dev/null +++ b/third_party/lisp/quasiquote_2/macros.lisp @@ -0,0 +1,15 @@ + +(in-package #:quasiquote-2.0) + +(defmacro define-dig-like-macro (name) + `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env) + (if (not form-p) + `(,',name 1 ,n-or-form) + (let ((*env* env)) + (transform-dig-form `(,',name ,n-or-form ,form)))))) + + +(define-dig-like-macro dig) +(define-dig-like-macro odig) + + diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp new file mode 100644 index 0000000000..9b140ef84c --- /dev/null +++ b/third_party/lisp/quasiquote_2/package.lisp @@ -0,0 +1,11 @@ +;;;; package.lisp + +(defpackage #:quasiquote-2.0 + (:use #:cl #:iterate) + (:export #:%codewalk-dig-form #:transform-dig-form + #:dig #:inject #:splice #:odig #:oinject #:osplice + #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice + #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all + #:enable-quasiquote-2.0 #:disable-quasiquote-2.0)) + + diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd new file mode 100644 index 0000000000..3acfd32b80 --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd @@ -0,0 +1,30 @@ +;;;; quasiquote-2.0.asd + +(defpackage :quasiquote-2.0-system + (:use :cl :asdf)) + +(in-package quasiquote-2.0-system) + +(asdf:defsystem #:quasiquote-2.0 + :serial t + :description "Writing macros that write macros. Effortless." + :author "Alexandr Popolitov <popolit@gmail.com>" + :license "MIT" + :version "0.3" + :depends-on (#:iterate) + :components ((:file "package") + (:file "quasiquote-2.0") + (:file "macros") + (:file "readers"))) + +(defsystem :quasiquote-2.0-tests + :description "Tests for QUASIQUOTE-2.0" + :licence "MIT" + :depends-on (:quasiquote-2.0 :fiveam) + :components ((:file "tests") + (:file "tests-macro") + )) + +(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0)))) + (load-system :quasiquote-2.0) + (funcall (intern "RUN-TESTS" :quasiquote-2.0))) diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp new file mode 100644 index 0000000000..10043fe0ec --- /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 0000000000..7c4c5a30c9 --- /dev/null +++ b/third_party/lisp/quasiquote_2/readers.lisp @@ -0,0 +1,77 @@ + + +(in-package #:quasiquote-2.0) + +(defun read-n-chars (stream char) + (let (new-char + (n 0)) + (loop + (setf new-char (read-char stream nil :eof t)) + (if (not (char= new-char char)) + (progn (unread-char new-char stream) + (return n)) + (incf n))))) + +(defmacro define-dig-reader (name symbol) + `(defun ,name (stream char) + (let ((depth (1+ (read-n-chars stream char)))) + (if (equal 1 depth) + (list ',symbol (read stream t nil t)) + (list ',symbol + depth + (read stream t nil t)))))) + +(define-dig-reader dig-reader dig) +(define-dig-reader odig-reader odig) + +(defun expect-char (char stream) + (let ((new-char (read-char stream t nil t))) + (if (char= char new-char) + t + (unread-char new-char stream)))) + +(defun guess-injector-name (opaque-p macro-p all-p splicing-p) + (intern (concatenate 'string + (if opaque-p "O" "") + (if macro-p "MACRO-" "") + (if splicing-p "SPLICE" "INJECT") + (if all-p "-ALL" "")) + "QUASIQUOTE-2.0")) + +(defun inject-reader (stream char) + (let ((anti-depth (1+ (read-n-chars stream char))) + (extended-syntax (expect-char #\! stream))) + (let ((injector-name (if (not extended-syntax) + (guess-injector-name nil nil nil (expect-char #\@ stream)) + (guess-injector-name (expect-char #\o stream) + (expect-char #\m stream) + (expect-char #\a stream) + (expect-char #\@ stream))))) + `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth)) + ,(read stream t nil t))))) + + + +(defvar *previous-readtables* nil) + +(defun %enable-quasiquote-2.0 () + (push *readtable* + *previous-readtables*) + (setq *readtable* (copy-readtable)) + (set-macro-character #\` #'dig-reader) + (set-macro-character #\, #'inject-reader) + (values)) + +(defun %disable-quasiquote-2.0 () + (if *previous-readtables* + (setf *readtable* (pop *previous-readtables*)) + (setf *readtable* (copy-readtable nil))) + (values)) + +(defmacro enable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-quasiquote-2.0))) +(defmacro disable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-quasiquote-2.0))) + diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp new file mode 100644 index 0000000000..df6c43e21d --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests-macro.lisp @@ -0,0 +1,21 @@ + +(in-package #:quasiquote-2.0-tests) + +(in-suite quasiquote-2.0) + +(enable-quasiquote-2.0) + +(defmacro define-sample-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-macroexpand-to + ,,@body))) + +(define-sample-macro sample-macro-1 (x y) + ,x ,y) + +(define-sample-macro sample-macro-2 (&body body) + ,@body) + +(test macro-defined-macroexpansions + (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b)))) + (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c))))) \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp new file mode 100644 index 0000000000..6c8ab08cc1 --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests.lisp @@ -0,0 +1,143 @@ +(in-package :cl-user) + +(defpackage :quasiquote-2.0-tests + (:use :cl :quasiquote-2.0 :fiveam) + (:export #:run-tests)) + +(in-package :quasiquote-2.0-tests) + +(def-suite quasiquote-2.0) +(in-suite quasiquote-2.0) + +(defun run-tests () + (let ((results (run 'quasiquote-2.0))) + (fiveam:explain! results) + (unless (fiveam:results-status results) + (error "Tests failed.")))) + +(test basic + (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a)))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a)))))) + (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d))))))) + (is (equal '(nil nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d)))))))) + (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d))))))))) + +(test transform + (is (equal '(quote a) (transform-dig-form '(dig a)))) + (is (equal '(quote a) (transform-dig-form '(dig 2 a)))) + (is (equal 'a (transform-dig-form '(dig (inject a))))) + (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a)))))) + +(defun foo (b d) + (dig (a (inject b) c (inject d)))) + +(defun foo1-transparent (x) + (declare (ignorable x)) + (dig (dig (a (inject (b (inject x) c)))))) + +(defun foo1-opaque (x) + (declare (ignorable x)) + (dig (dig (a (oinject (b (inject x) c)))))) + +(defun foo-recursive (x y) + (dig (a (inject (list x (dig (c (inject y)))))))) + + +(test foos + (is (equal '(a 1 c 2) (foo 1 2))) + (is (equal '(a 100 c 200) (foo 100 200)))) + +(test opaque-vs-transparent + (is (equal '(quote a) (transform-dig-form '(odig a)))) + (is (equal '(quote a) (transform-dig-form '(odig 2 a)))) + (is (equal 'a (transform-dig-form '(odig (inject a))))) + (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a))))) + (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a))))))) + (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3))) + (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3)))) + +(test recursive-compile-time + (is (equal '(a (1 (c 2))) (foo-recursive 1 2)))) + + +(test splicing + (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d)))))) + (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d)))))) + (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c)))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b)))))) + (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b)))))) + (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil))))))) + (is (equal '() (eval (transform-dig-form '(dig ((splice nil))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b))))))))) + + +(test are-they-macro + (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b)))))) + (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b))))))) + + +(defmacro triple-var (x) + `((inject ,x) (inject ,x) (inject ,x))) + +(test correct-order-of-effects + (is (equal '(a 1 2 3) (let ((x 0)) + (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x))))))) + (is (equal '(a (((1))) 2) + (let ((x 0)) + (dig (a ((((inject (incf x))))) (inject (incf x)))))))) + +(test macro-injects + (is (equal '(a (3 3 3)) (let ((x 3)) + (dig (a (macro-inject (triple-var x))))))) + (is (equal '(a (1 2 3)) (let ((x 0)) + (dig (a (macro-inject (triple-var (incf x)))))))) + (macrolet ((frob (form n) + (mapcar (lambda (x) + `(inject ,x)) + (make-list n :initial-element form))) + (frob1 (form) + `(frob ,form 4))) + (is (equal '(a (1 2 3 4 5)) + (let ((x 0)) + (dig (a (macro-inject (frob (incf x) 5))))))) + (is (equal '(a 1 2 3 4 5) + (let ((x 0)) + (dig (a (macro-splice (frob (incf x) 5))))))) + (is (equal '(a) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob (incf x) 0))))))) + (is (equal '(a frob (incf x) 4) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob1 (incf x)))))))) + (is (equal '(a 1 2 3 4) + (let ((x 0)) + (dig (a (macro-splice-all (frob1 (incf x)))))))))) + + +(quasiquote-2.0:enable-quasiquote-2.0) + +(test reader + (is (equal '(inject x) ',x)) + (is (equal '(inject 3 x) ',,,x)) + (is (equal '(splice x) ',@x)) + (is (equal '(splice 3 x) ',,,@x)) + (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x)) + (is (equal '(inject 4 oma@x) ',,,,oma@x))) + +(test macro-splices + (macrolet ((splicer (x) + ``(splice ,x))) + (is (equal '(a 1 2 3) (let ((x '(1 2 3))) + `(a ,!m(splicer x))))))) + +(test repeated-splices + (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil))) + (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g))))) + + \ No newline at end of file diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix new file mode 100644 index 0000000000..b82a490c9d --- /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 0000000000..fc7d4e3067 --- /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 0000000000..9c4da4a02b --- /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 0000000000..9e5838c3c5 --- /dev/null +++ b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch @@ -0,0 +1,26 @@ +From 789dc38399f4039b114de28384c149721d66b030 Mon Sep 17 00:00:00 2001 +From: Vincent Ambo <mail@tazj.in> +Date: Thu, 16 Dec 2021 00:48:04 +0300 +Subject: [PATCH] fix definition order in xml.lisp + +--- + src/xml.lisp | 3 +++ + 1 file changed, 3 insertions(+) + +diff --git a/src/xml.lisp b/src/xml.lisp +index 39c9b63..3232491 100644 +--- a/src/xml.lisp ++++ b/src/xml.lisp +@@ -19,6 +19,9 @@ + + ;;; error reporting + ++(defvar *ignore-namespaces* nil ++ "When t, namespaces are ignored like in the old version of S-XML") ++ + (define-condition xml-parser-error (error) + ((message :initarg :message :reader xml-parser-error-message) + (args :initarg :args :reader xml-parser-error-args) +-- +2.34.0 + diff --git a/third_party/lisp/s-xml/default.nix b/third_party/lisp/s-xml/default.nix new file mode 100644 index 0000000000..486e1c1ac8 --- /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/sclf/.skip-subtree b/third_party/lisp/sclf/.skip-subtree new file mode 100644 index 0000000000..5051f60d6b --- /dev/null +++ b/third_party/lisp/sclf/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/sclf/OWNERS b/third_party/lisp/sclf/OWNERS new file mode 100644 index 0000000000..f16dd105d7 --- /dev/null +++ b/third_party/lisp/sclf/OWNERS @@ -0,0 +1,3 @@ +inherited: true +owners: + - sterni diff --git a/third_party/lisp/sclf/README b/third_party/lisp/sclf/README new file mode 100644 index 0000000000..2a1c2c3c5c --- /dev/null +++ b/third_party/lisp/sclf/README @@ -0,0 +1,6 @@ +SCLF has originally been written by Walter C. Pelissero and vendored +into depot since it is a dependency of mime4cl. Upstream and depot version +may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#sclf +Vendored Tarball: http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz diff --git a/third_party/lisp/sclf/default.nix b/third_party/lisp/sclf/default.nix new file mode 100644 index 0000000000..fb07f8f764 --- /dev/null +++ b/third_party/lisp/sclf/default.nix @@ -0,0 +1,28 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "sclf"; + + deps = [ + (depot.nix.buildLisp.bundled "sb-posix") + ]; + + srcs = [ + ./package.lisp + ./sclf.lisp + ./sysproc.lisp + ./lazy.lisp + ./time.lisp + ./directory.lisp + ./serial.lisp + ./mp/sbcl.lisp + ]; + + # TODO(sterni): implement OS interaction for ECL and CCL + brokenOn = [ + "ecl" + "ccl" + ]; +} diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp new file mode 100644 index 0000000000..3e479c4ac2 --- /dev/null +++ b/third_party/lisp/sclf/directory.lisp @@ -0,0 +1,404 @@ +;;; directory.lisp --- filesystem directory access + +;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: directory.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + + +(cl:in-package :sclf) + +(defun pathname-as-directory (pathname) + "Converts PATHNAME to directory form and return it." + (setf pathname (pathname pathname)) + (if (pathname-name pathname) + (make-pathname :directory (append (or (pathname-directory pathname) + '(:relative)) + (list (file-namestring pathname))) + :name nil + :type nil + :defaults pathname) + pathname)) + +(defun d+ (path &rest rest) + "Concatenate directory pathname parts and return a pathname." + (make-pathname :defaults path + :directory (append (pathname-directory path) rest))) + +(defun delete-directory (pathname) + "Remove directory PATHNAME. Return PATHNAME." + #+cmu (multiple-value-bind (done errno) + (unix:unix-rmdir (namestring pathname)) + (unless done + (error "Unable to delete directory ~A (errno=~A)" + pathname errno))) + #+sbcl (sb-posix:rmdir pathname) + #+lispworks (lw:delete-directory pathname) + #-(or cmu sbcl) + (error "DELETE-DIRECTORY not implemented for you lisp system.") + pathname) + +(defun list-directory (pathname &key truenamep) + "List content of directory PATHNAME. If TRUENAMEP is true don't try +to follow symbolic links." + #-(or sbcl cmu) (declare (ignore truenamep)) + (let (#+cmu (lisp::*ignore-wildcards* t)) + (directory (make-pathname :defaults (pathname-as-directory pathname) + :name :wild + :type :wild + :version :wild) + #+cmu :truenamep #+cmu truenamep + #+sbcl :resolve-symlinks #+sbcl truenamep))) + +(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first) + "Call PROC on all pathnames under ROOT-PATHNAME, both files and +directories. Unless TRUENAMEP is true, this function doesn't try +to lookup the truename of files, as finding the truename may be a +superfluous and noxious activity expecially when you expect +broken symbolic links in your filesystem." + (check-type root-pathname pathname) + (check-type proc (or function symbol)) + (check-type test (or function symbol null)) + (labels ((ls (dir) + (declare (type pathname dir)) + (list-directory dir :truenamep truenamep)) + (traverse? (file) + (declare (type pathname file)) + (and (not (pathname-name file)) + (or truenamep + (not (symbolic-link-p file))) + (or (not test) + (funcall test file)))) + (traverse-pre-order (dir) + (declare (type pathname dir)) + (loop + for file in (ls dir) + do (funcall proc file) + when (traverse? file) + do (traverse-pre-order file))) + (traverse-post-order (dir) + (declare (type pathname dir)) + (loop + for file in (ls dir) + when (traverse? file) + do (traverse-post-order file) + do (funcall proc file)))) + (if depth-first + (traverse-post-order root-pathname) + (traverse-pre-order root-pathname)) + (values))) + +(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body) + "Call TRAVERSE-DIRECTORY-TREE with BODY es procedure." + `(traverse-directory-tree ,root-pathname + #'(lambda (,file) + ,@body) + :truenamep ,truenamep + :test ,test + :depth-first ,depth-first)) + +(defun empty-directory-p (pathname) + (and (directory-p pathname) + (endp (list-directory pathname)))) + +(defun remove-empty-directories (root) + (do-directory-tree (pathname root :depth-first t) + (when (empty-directory-p pathname) + (delete-directory pathname)))) + +(defun map-directory-tree (pathname function) + "Apply FUNCTION to every file in a directory tree starting from +PATHNAME. Return the list of results." + (be return-list '() + (do-directory-tree (directory-entry pathname) + (push (funcall function directory-entry) return-list)) + (nreverse return-list))) + +(defun find-files (root-pathname matcher-function &key truenamep) + "In the directory tree rooted at ROOT-PATHNAME, find files that +when the pathname is applied to MATCHER-FUNCTION will return +true. Return the list of files found. Unless TRUENAMEP is true +this function doesn't try to lookup the truename of +files. Finding the truename may be a superfluous and noxious +activity expecially when you expect broken symbolic links in your +filesystem. (This may not apply to your particular lisp +system.)" + (be files '() + (do-directory-tree (file root-pathname :truenamep truenamep) + (when (funcall matcher-function file) + (push file files))) + (nreverse files))) + +(defun delete-directory-tree (pathname) + "Recursively delete PATHNAME and all the directory structure below +it. + +WARNING: depending on the way the DIRECTORY function is implemented on +your Lisp system this function may follow Unix symbolic links and thus +delete files outside the PATHNAME hierarchy. Check this before using +this function in your programs." + (if (pathname-name pathname) + (delete-file pathname) + (progn + (dolist (file (list-directory pathname)) + (delete-directory-tree file)) + (delete-directory pathname)))) + +(defun make-directory (pathname &optional (mode #o777)) + "Create a new directory in the filesystem. Permissions MODE +will be assigned to it. Return PATHNAME." + #+cmu (multiple-value-bind (done errno) + (unix:unix-mkdir (native-namestring pathname) mode) + (unless done + (error "Unable to create directory ~A (errno=~A)." pathname errno))) + #+sbcl (sb-posix:mkdir pathname mode) + #-(or cmu sbcl) + (error "MAKE-DIRECTORY is not implemented for this Lisp system.") + pathname) + +;; At least on SBCL/CMUCL + Unix + NFS this function is faster than +;; ENSURE-DIRECTORIES-EXIST, because it doesn't check all the pathname +;; components starting from the root; it proceeds from the leaf and +;; crawls the directory tree upward only if necessary." +(defun ensure-directory (pathname &key verbose (mode #o777)) + "Just like ENSURE-DIRECTORIES-EXIST but, in some situations, +it's faster." + (labels ((ensure (path) + (unless (probe-file path) + (be* tail (last (pathname-directory path) 2) + last (cdr tail) + (setf (cdr tail) nil) + (unwind-protect + (ensure path) + (setf (cdr tail) last)) + (make-directory path mode) + (when verbose + (format t "Created ~S~%" path)))))) + (ensure (make-pathname :defaults pathname + :name nil :type nil + :version nil)))) + +(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777)) + "Create a new directory and return its pathname. +If DEFAULT-PATHNAME is specified and not NIL it's used as +defaults to produce the pathname of the directory. Return the +pathname of the temporary directory." + (loop + for name = (pathname-as-directory (temp-file-name default-pathname)) + when (ignore-errors (make-directory name mode)) + return name)) + +(defmacro with-temp-directory ((path &rest make-temp-directory-args) &body body) + "Execute BODY with PATH bound to the pathname of a new unique +temporary directory. On exit of BODY the directory tree starting from +PATH will be automatically removed from the filesystem. Return what +BODY returns. BODY is _not_ executed within the PATH directory; the +working directory is never changed." + `(be ,path (make-temp-directory ,@make-temp-directory-args) + (unwind-protect + (progn ,@body) + (delete-directory-tree ,path)))) + +(defun current-directory () + "Return the pathname of the current directory." + (truename (make-pathname :directory '(:relative)))) + +(defun ensure-home-translations () + "Ensure that the logical pathname translations for the host \"home\" +are defined." + ;; CMUCL already defines a HOME translation of its own and gets + ;; angry if we try to redefine it + #-cmu + (be home (user-homedir-pathname) + ;; we should discard and replace whatever has been defined in any + ;; rc file during compilation + (setf (logical-pathname-translations "home") + (list + (list "**;*.*.*" + (make-pathname :defaults home + :directory (append (pathname-directory home) + '(:wild-inferiors)) + :name :wild + :type :wild)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) + #+sbcl (sb-ext:parse-native-namestring string host defaults + :start start + :end end + :junk-allowed junk-allowed) + #-sbcl (let (#+cmu(lisp::*ignore-wildcards* t)) + (parse-namestring string host defaults + :start start + :end end + :junk-allowed junk-allowed))) + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +(defun native-file-namestring (pathname) + #+sbcl (sb-ext:native-namestring + (make-pathname :name (pathname-name pathname) + :type (pathname-type pathname))) + #+cmu (be lisp::*ignore-wildcards* t + (file-namestring pathname))) + +(defun native-pathname (thing) + #+sbcl (sb-ext:native-pathname thing) + #+cmu (be lisp::*ignore-wildcards* t + (pathname thing))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun bits-set-p (x bits) + (= (logand x bits) + bits)) + +(defun directory-p (pathname) + "Return true if PATHNAME names a directory on the filesystem." + #-clisp (awhen (unix-stat (native-namestring pathname)) + (bits-set-p (stat-mode it) + #+sbcl sb-posix:s-ifdir + #+cmu unix:s-ifdir)) + #+clisp (ext:probe-directory (pathname-as-directory pathname))) + +(defun regular-file-p (pathname) + "Return true if PATHNAME names a regular file on the filesystem." + #-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file") + (awhen (unix-stat (native-namestring pathname)) + (bits-set-p (stat-mode it) + #+sbcl sb-posix:s-ifreg + #+cmu unix:s-ifreg))) + +(defun file-readable-p (pathname) + #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok) + #+cmu (unix:unix-access (native-namestring pathname) unix:r_ok) + #-(or sbcl cmu) (error "don't know how to check whether a file might be readable")) + +(defun file-writable-p (pathname) + #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:w_ok) + #+cmu (unix:unix-access (native-namestring pathname) unix:w_ok) + #-(or sbcl cmu) (error "don't know how to check whether a file might be writable")) + +(defun file-executable-p (pathname) + #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:x_ok) + #+cmu (unix:unix-access (native-namestring pathname) unix:x_ok) + #-(or sbcl cmu) (error "don't know how to check whether a file might be executable")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (unix-file-stat (:conc-name stat-)) + device + inode + links + atime + mtime + ctime + size + blksize + blocks + uid + gid + mode) + +(defun unix-stat (pathname) + ;; this could be different depending on the unix systems + (multiple-value-bind (ok? device inode mode links uid gid rdev + size atime mtime ctime + blksize blocks) + (#+cmu unix:unix-lstat + #+sbcl sb-unix:unix-lstat + (if (stringp pathname) + pathname + (native-namestring pathname))) + (declare (ignore rdev)) + (when ok? + (make-unix-file-stat :device device + :inode inode + :links links + :atime atime + :mtime mtime + :ctime ctime + :size size + :blksize blksize + :blocks blocks + :uid uid + :gid gid + :mode mode)))) + +(defun stat-modification-time (stat) + "Return the modification time of the STAT structure as Lisp +Universal Time, which is not the same as the Unix time." + (unix->universal-time (stat-mtime stat))) + +(defun stat-creation-time (stat) + "Return the creation time of the STAT structure as Lisp +Universal Time, which is not the same as the Unix time." + (unix->universal-time (stat-ctime stat))) + +(defun file-modification-time (file) + "Return the modification time of FILE as Lisp Universal Time, which +is not the same as the Unix time." + (awhen (unix-stat file) + (stat-modification-time it))) + +(defun file-creation-time (file) + "Return the creation time of FILE as Lisp Universal Time, which +is not the same as the Unix time." + (awhen (unix-stat file) + (stat-creation-time it))) + +(defun read-symbolic-link (symlink) + "Return the pathname the SYMLINK points to. That is, it's +contents." + #+sbcl (sb-posix:readlink (native-namestring symlink)) + #+cmu (unix:unix-readlink (native-namestring symlink))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + (stat-size (unix-stat pathname))) + +(defun symbolic-link-p (pathname) + #-(or sbcl cmu) (error "don't know hot to test for symbolic links.") + (aand (unix-stat pathname) + (bits-set-p (stat-mode it) + #+sbcl sb-posix:s-iflnk + #+cmu unix:s-iflnk))) + +(defun broken-link-p (pathname) + (when (symbolic-link-p pathname) + #+cmu (not (ignore-errors (truename pathname))) + ;; On a broken symlink SBCL returns the link path without resolving + ;; the link itself. De gustibus non est disputandum. + #+sbcl (equalp pathname (probe-file pathname)))) + +(defun move-file (old new) + "Just like RENAME-FILE, but doesn't carry on to NEW file the type of +OLD file, if NEW doesn't specify one. It does what most people would +expect from a rename function, which RENAME-FILE doesn't do. +So (MOVE-FILE \"foo.bar\" \"foo\") does rename foo.bar to foo, losing +the \"bar\" type; RENAME-FILE wouldn't allow you that." + #+sbcl (sb-posix:rename (native-namestring old) (native-namestring new)) + #+cmu (unix:unix-rename (native-namestring old) (native-namestring new))) diff --git a/third_party/lisp/sclf/lazy.lisp b/third_party/lisp/sclf/lazy.lisp new file mode 100644 index 0000000000..34bae82ebb --- /dev/null +++ b/third_party/lisp/sclf/lazy.lisp @@ -0,0 +1,134 @@ +;;; lazy.lisp --- lazy primitives + +;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: lazy.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Lazy primitives +;;; + +(in-package :sclf) + +(defstruct promise + procedure + value) + +(defmacro lazy (form) + `(make-promise :procedure #'(lambda () ,form))) + +(defun forced-p (promise) + (null (promise-procedure promise))) + +(defun force (promise) + (if (forced-p promise) + (promise-value promise) + (prog1 (setf (promise-value promise) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) + +(defmacro deflazy (name value &optional documentation) + `(defparameter ,name (lazy ,value) + ,@(when documentation + (list documentation)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass lazy-metaclass (standard-class) + () + (:documentation "Metaclass for object having lazy slots. Lazy slots +should be specified with the :LAZY keyword which must be a function of +one argument. If required this function will be called once to get +the value to memoize in the slot. Lazy slots can also be set/read as +any other.")) + +(defmethod validate-superclass ((class lazy-metaclass) (super standard-class)) + "Lazy classes may inherit from ordinary classes." + (declare (ignore class super)) + t) + +(defmethod validate-superclass ((class standard-class) (super lazy-metaclass)) + "Ordinary classes may inherit from lazy classes." + (declare (ignore class super)) + t) + +(defclass lazy-slot-mixin () + ((lazy-function :initarg :lazy + :reader lazy-slot-function + :initform nil)) + (:documentation + "Slot for LAZY-METACLASS classes. Lazy slots must be declared with +the argument :LAZY which must be a function accepting the object +instance as argument.")) + +(defclass lazy-direct-slot-definition (lazy-slot-mixin standard-direct-slot-definition) + ()) + +(defclass lazy-effective-slot-definition (lazy-slot-mixin standard-effective-slot-definition) + ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod direct-slot-definition-class ((class lazy-metaclass) &rest initargs) + (if (getf initargs :lazy nil) + (find-class 'lazy-direct-slot-definition) + (call-next-method))) + +(defmethod effective-slot-definition-class ((class lazy-metaclass) &rest initargs) + (if (getf initargs :lazy nil) + (find-class 'lazy-effective-slot-definition) + (call-next-method))) + +(defmethod compute-effective-slot-definition-initargs ((class lazy-metaclass) direct-slots) + (let ((ds (car direct-slots))) + (if (typep ds 'lazy-direct-slot-definition) + (let ((form (lazy-slot-function ds)) + (args (call-next-method))) + (when (or (getf args :initarg) + (getf args :initform)) + (error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds)) + (list* :lazy + (cond ((and (listp form) + (eq 'lambda (car form))) + (compile nil form)) + ((symbolp form) + form) + (t (compile nil `(lambda (self) + (declare (ignorable self)) + ,form)))) + args)) + (call-next-method)))) + +(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin)) + (declare (ignore class)) + ;; If the slot is unbound, call the lazy function passing the + ;; instance and memoize the value in the slot. + (unless (slot-boundp-using-class class instance slot) + (setf (slot-value-using-class class instance slot) + (funcall (lazy-slot-function slot) instance))) + (call-next-method)) + +(defun reset-lazy-slots (object) + "Unbind all the lazy slots in OBJECT so that they will be +re-evaluated next time their value is requested again." + (be* class (class-of object) + (dolist (slot (class-slots class)) + (when (typep slot 'lazy-effective-slot-definition) + (slot-makunbound object (slot-definition-name slot)))))) \ No newline at end of file diff --git a/third_party/lisp/sclf/mp/README b/third_party/lisp/sclf/mp/README new file mode 100644 index 0000000000..a0732c0294 --- /dev/null +++ b/third_party/lisp/sclf/mp/README @@ -0,0 +1,6 @@ +This directory contains an uniforming layer for multiprocessing in the +style supported by Allegro Common Lisp and CMUCL. Almost nothing of +this has been written by me. It's mostly the work of Gilbert Baumann +(unk6@rz.uni-karlsruhe.de) and I've shamelessly lifted it from McCLIM. +The copyright disclaimer in this code is compatible with the one of +SCLF, so I believe there should be no legal issues. diff --git a/third_party/lisp/sclf/mp/cmu.lisp b/third_party/lisp/sclf/mp/cmu.lisp new file mode 100644 index 0000000000..1bdbba7989 --- /dev/null +++ b/third_party/lisp/sclf/mp/cmu.lisp @@ -0,0 +1,115 @@ +;;; +;;; Code freely lifted from various places with compatible license +;;; terms. Most of this code is copyright Gilbert Baumann +;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter +;;; C. Pelissero <walter@pelissero.de>. +;;; + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +(in-package :sclf) + +(defun make-lock (&optional name) + (mp:make-lock name)) + +(defun make-recursive-lock (&optional name) + (mp:make-lock name :kind :recursive)) + +(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms) + `(mp:with-lock-held (,lock ,(or whostate "Lock Wait") + :wait wait + ,@(when timeout (list :timeout timeout))) + ,@forms)) + +(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms) + `(mp:with-lock-held (,lock + ,@(when wait (list :wait wait)) + ,@(when timeout (list :timeout timeout))) + ,@forms)) + +(defstruct condition-variable + (lock (make-lock "condition variable")) + (value nil) + (process-queue nil)) + +(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp + #+i486 (kernel:%instance-set-conditional + lock 2 mp:*current-process* nil) + #-i486 (when (eq (lock-process lock) mp:*current-process*) + (setf (lock-process lock) nil))) + +(defun condition-wait (cv lock &optional timeout) + (declare (ignore timeout)) ;For now + (loop + (let ((cv-lock (condition-variable-lock cv))) + (with-lock-held (cv-lock) + (when (condition-variable-value cv) + (setf (condition-variable-value cv) nil) + (return-from condition-wait t)) + (setf (condition-variable-process-queue cv) + (nconc (condition-variable-process-queue cv) + (list mp:*current-process*))) + (%release-lock lock)) + (mp:process-add-arrest-reason mp:*current-process* cv) + (let ((cv-val nil)) + (with-lock-held (cv-lock) + (setq cv-val (condition-variable-value cv)) + (when cv-val + (setf (condition-variable-value cv) nil))) + (when cv-val + (mp::lock-wait lock "waiting for condition variable lock") + (return-from condition-wait t)))))) + +(defun condition-notify (cv) + (with-lock-held ((condition-variable-lock cv)) + (let ((proc (pop (condition-variable-process-queue cv)))) + ;; The waiting process may have released the CV lock but not + ;; suspended itself yet + (when proc + (loop + for activep = (mp:process-active-p proc) + while activep + do (mp:process-yield)) + (setf (condition-variable-value cv) t) + (mp:process-revoke-arrest-reason proc cv)))) + ;; Give the other process a chance + (mp:process-yield)) + +(defun process-execute (process function) + (mp:process-preset process function) + ;; For some obscure reason process-preset doesn't make the process + ;; runnable. I'm sure it's me who didn't understand how + ;; multiprocessing works under CMUCL, despite the vast documentation + ;; available. + (mp:enable-process process) + (mp:process-add-run-reason process :enable)) + +(defun destroy-process (process) + ;; silnetly ignore a process that is trying to destroy itself + (unless (eq (mp:current-process) + process) + (mp:destroy-process process))) + +(defun restart-process (process) + (mp:restart-process process) + (mp:enable-process process) + (mp:process-add-run-reason process :enable)) + +(defun process-alive-p (process) + (mp:process-alive-p process)) + +(defun process-join (process) + (error "PROCESS-JOIN not support under CMUCL.")) diff --git a/third_party/lisp/sclf/mp/sbcl.lisp b/third_party/lisp/sclf/mp/sbcl.lisp new file mode 100644 index 0000000000..a2cf497ff9 --- /dev/null +++ b/third_party/lisp/sclf/mp/sbcl.lisp @@ -0,0 +1,235 @@ +;;; +;;; Code freely lifted from various places with compatible license +;;; terms. Most of this code is copyright Daniel Barlow +;;; <dan@metacircles.com> or Gilbert Baumann +;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter +;;; C. Pelissero <walter@pelissero.de>. +;;; + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +(in-package :sclf) + +(defstruct (process + (:constructor %make-process) + (:predicate processp)) + name + state + whostate + function + thread) + +(defvar *current-process* + (%make-process + :name "initial process" :function nil + :thread + #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) + sb-thread:*current-thread* + #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) + (sb-thread:current-thread-id))) + +(defvar *all-processes* (list *current-process*)) + +(defvar *all-processes-lock* + (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) + +;; we implement disable-process by making the disablee attempt to lock +;; *permanent-queue*, which is already locked because we locked it +;; here. enable-process just interrupts the lock attempt. + +(defmacro get-mutex (mutex &optional (wait t)) + `( + #+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) + sb-thread:grab-mutex + #-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) + sb-thread:get-mutex + ,mutex :waitp ,wait)) + +(defvar *permanent-queue* + (sb-thread:make-mutex :name "Lock for disabled threads")) +(unless (sb-thread:mutex-owner *permanent-queue*) + (get-mutex *permanent-queue* nil)) + +(defun make-process (function &key name) + (let ((p (%make-process :name name + :function function))) + (sb-thread:with-mutex (*all-processes-lock*) + (pushnew p *all-processes*)) + (restart-process p))) + +(defun process-kill-thread (process) + (let ((thread (process-thread process))) + (when (and thread + (sb-thread:thread-alive-p thread)) + (assert (not (eq thread sb-thread:*current-thread*))) + (sb-thread:terminate-thread thread) + ;; Wait until all the clean-up forms are done. + (sb-thread:join-thread thread :default nil)) + (setf (process-thread process) nil))) + +(defun process-join (process) + (sb-thread:join-thread (process-thread process))) + +(defun restart-process (p) + (labels ((boing () + (let ((*current-process* p) + (function (process-function p))) + (when function + (funcall function))))) + (process-kill-thread p) + (when (setf (process-thread p) + (sb-thread:make-thread #'boing :name (process-name p))) + p))) + +(defun destroy-process (process) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete process *all-processes*))) + (process-kill-thread process)) + +(defun current-process () + *current-process*) + +(defun all-processes () + ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value + ;; while that delete is executing, we could end up with nonsense. + ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS). + (sb-thread:with-mutex (*all-processes-lock*) + *all-processes*)) + +(defun process-yield () + (sb-thread:thread-yield)) + +(defun process-wait (reason predicate) + (let ((old-state (process-whostate *current-process*))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (until (funcall predicate) + (process-yield))) + (setf (process-whostate *current-process*) old-state)))) + +(defun process-wait-with-timeout (reason timeout predicate) + (let ((old-state (process-whostate *current-process*)) + (end-time (+ (get-universal-time) timeout))) + (unwind-protect + (progn + (setf old-state (process-whostate *current-process*) + (process-whostate *current-process*) reason) + (loop + for result = (funcall predicate) + until (or result + (> (get-universal-time) end-time)) + do (process-yield) + finally (return result))) + (setf (process-whostate *current-process*) old-state)))) + +(defun process-interrupt (process function) + (sb-thread:interrupt-thread (process-thread process) function)) + +(defun disable-process (process) + (sb-thread:interrupt-thread + (process-thread process) + (lambda () + (catch 'interrupted-wait (get-mutex *permanent-queue*))))) + +(defun enable-process (process) + (sb-thread:interrupt-thread + (process-thread process) (lambda () (throw 'interrupted-wait nil)))) + +(defmacro without-scheduling (&body body) + (declare (ignore body)) + (error "WITHOUT-SCHEDULING is not supported on this platform.")) + +(defparameter *atomic-lock* + (sb-thread:make-mutex :name "atomic incf/decf")) + +(defmacro atomic-incf (place) + `(sb-thread:with-mutex (*atomic-lock*) + (incf ,place))) + +(defmacro atomic-decf (place) + `(sb-thread:with-mutex (*atomic-lock*) + (decf ,place))) + +;;; 32.3 Locks + +(defun make-lock (&optional name) + (sb-thread:make-mutex :name name)) + +(defmacro with-lock-held ((place &key state (wait t) timeout) &body body) + (declare (ignore timeout)) + (let ((old-state (gensym "OLD-STATE"))) + `(sb-thread:with-mutex (,place :wait-p ,wait) + (let (,old-state) + (unwind-protect + (progn + (when ,state + (setf ,old-state (process-state *current-process*)) + (setf (process-state *current-process*) ,state)) + ,@body) + (setf (process-state *current-process*) ,old-state)))))) + + +(defun make-recursive-lock (&optional name) + (sb-thread:make-mutex :name name)) + +(defmacro with-recursive-lock-held ((place &optional state (wait t) timeout) &body body) + (declare (ignore wait timeout)) + (let ((old-state (gensym "OLD-STATE"))) + `(sb-thread:with-recursive-lock (,place) + (let (,old-state) + (unwind-protect + (progn + (when ,state + (setf ,old-state (process-state *current-process*)) + (setf (process-state *current-process*) ,state)) + ,@body) + (setf (process-state *current-process*) ,old-state)))))) + +(defun make-condition-variable () (sb-thread:make-waitqueue)) + +(defun condition-wait (cv lock &optional timeout) + (if timeout + (handler-case + (sb-ext:with-timeout timeout + (sb-thread:condition-wait cv lock) + t) + (sb-ext:timeout (c) + (declare (ignore c)) + nil)) + (progn (sb-thread:condition-wait cv lock) t))) + +(defun condition-notify (cv) + (sb-thread:condition-notify cv)) + + +(defvar *process-plists* (make-hash-table) + "Hash table mapping processes to a property list. This is used by +PROCESS-PLIST.") + +(defun process-property-list (process) + (gethash process *process-plists*)) + +(defun (setf process-property-list) (value process) + (setf (gethash process *process-plists*) value)) + +(defun process-execute (process function) + (setf (process-function process) function) + (restart-process process)) + +(defun process-alive-p (process) + (sb-thread:thread-alive-p (process-thread process))) diff --git a/third_party/lisp/sclf/package.lisp b/third_party/lisp/sclf/package.lisp new file mode 100644 index 0000000000..565ab301c7 --- /dev/null +++ b/third_party/lisp/sclf/package.lisp @@ -0,0 +1,258 @@ +;;; package.lisp --- packages description + +;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :sclf + (:use :common-lisp + ;; we need the MOP for lazy.lisp and serial.lisp + #+cmu :pcl + #+sbcl :sb-mop) + ;; Don't know why but compute-effective-slot-definition-initargs is + ;; internal in both CMUCL and SBCL + (:import-from #+cmu"PCL" #+sbcl"SB-PCL" + #-(or cmu sbcl) "CLOS" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS") + #+cmu (:import-from :mp + #:make-process + #:current-process + #:all-processes + #:processp + #:process-name + #:process-state + #:process-whostate + #:process-wait + #:process-wait-with-timeout + #:process-yield + #:process-interrupt + #:disable-process + #:enable-process + #:without-scheduling + #:atomic-incf + #:atomic-decf + #:process-property-list) + (:export #:be #:be* + #:defconst + #:with-gensyms + #:d+ + #:s+ + #:f++ + #:list->string + #:string-starts-with #:string-ends-with + #:aif #:awhen #:acond #:aand #:acase #:it + #:+whitespace+ + #:string-trim-whitespace + #:string-right-trim-whitespace + #:string-left-trim-whitespace + #:whitespace-p #:seq-whitespace-p + #:not-empty + #:position-any + #:+month-names+ + #:find-any + #:split-at + #:split-string-at-char + #:week-day->string + #:month->string + #:month-string->number + #:add-months #:add-days + #:read-whole-stream + #:read-file #:write-file #:read-lines + #:read-from-file #:write-to-file + #:string-concat + #:gcase + #:string-truncate + #:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots + #:copy-stream #:copy-file + #:symlink-file + #:keywordify + #:until + #:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year + #:beginning-of-week #:end-of-week + #:next-week-day #:next-monday #:full-weeks-in-span + #:beginning-of-first-week #:end-of-last-week + #:beginning-of-month #:end-of-month + #:locate-system-program + #:*tmp-file-defaults* + #:temp-file-name + #:open-temp-file + #:with-temp-file + #:file-size + #:getenv + #:with-system-environment + #:time-string #:iso-time-string #:parse-iso-time-string + #:soundex + #:string-soundex= + #:lru-cache + #:getcache #:cached + #:print-time-span + #:double-linked-list #:limited-list #:sorted-list + #:insert #:size + #:heap #:heap-add #:heap-pop #:heap-empty-p + #:double-linked-element #:make-double-linked-element #:double-linked-element-p + #:dle-previous #:dle-next #:dle-value + #:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle* + #:sl-map #:do-dll #:do-dll* + #:dll-find #:dll-find-cursor + #:push-first #:push-last #:dll-remove + #:pop-first #:pop-last + #:leap-year-p #:last-day-of-month + #:getuid #:setuid #:with-euid + #:get-logname #:get-user-name #:get-user-home #:find-uid + #:super-user-p + #:pathname-as-directory #:pathname-as-file + #:alist->plist #:plist->alist + #:byte-vector->string + #:string->byte-vector + #:outdated-p + #:with-hidden-temp-file + #:let-places #:let-slots + #:*decimal-point* + #:*thousands-comma* + #:format-amount #:parse-amount + #:with-package + #:make-directory #:ensure-directory + #:make-temp-directory + #:with-temp-directory + #:delete-directory + #:delete-directory-tree + #:do-directory-tree + #:traverse-directory-tree + #:empty-directory-p + #:remove-empty-directories + #:map-directory-tree + #:find-files + #:directory-p + #:regular-file-p + #:file-readable-p + #:file-writable-p + #:file-executable-p + #:current-directory + #:ensure-home-translations + #:list-directory + #:string-escape + #:string-substitute + #:bytes-simple-string + #:make-lock-files + #:with-lock-files + #:getpid + #:on-error + #:floor-to + #:round-to + #:ceiling-to + #:insert-in-order + #:forget-documentation + #:load-compiled + #:swap + #:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p + #:unix-stat #:unix-file-stat + #:stat-device + #:stat-inode + #:stat-links + #:stat-atime + #:stat-mtime + #:stat-ctime + #:stat-birthtime + #:stat-size + #:stat-blksize + #:stat-blocks + #:stat-uid + #:stat-gid + #:stat-mode + #:save-file-excursion + #:stat-modification-time + #:stat-creation-time + #:file-modification-time + #:file-creation-time + #:show + #:memoize-function + #:memoized + #:defun-memoized + #:parse-native-namestring + #:native-file-namestring + #:native-namestring + #:native-pathname + #:read-symbolic-link + #:symbolic-link-p + #:broken-link-p + #:circular-list + #:last-member + #:glob->regex + #:universal->unix-time #:unix->universal-time + #:get-unix-time + #:move-file + + ;; sysproc.lisp + #:*run-verbose* + #:run-pipe + #:run-program + #:run-shell-command + #:run-async-shell-command + #:exit-code + #:with-open-pipe + #:*bourne-shell* + #:sysproc-kill + #:sysproc-input + #:sysproc-output + #:sysproc-alive-p + #:sysproc-pid + #:sysproc-p + #:sysproc-wait + #:sysproc-exit-code + #:sysproc-set-signal-callback + + ;; MP + #:make-process + #:destroy-process + #:current-process + #:all-processes + #:processp + #:process-name + #:process-state + #:process-whostate + #:process-wait + #:process-wait-with-timeout + #:process-yield + #:process-interrupt + #:disable-process + #:enable-process + #:restart-process + #:without-scheduling + #:atomic-incf + #:atomic-decf + #:process-property-list + #:process-alive-p + #:process-join + ;; + #:make-lock + #:with-lock-held + #:make-recursive-lock + #:with-recursive-lock-held + ;; + #:make-condition-variable + #:condition-wait + #:condition-notify + #:process-property-list + #:process-execute + ;; mop.lisp + #:printable-object-mixin + )) diff --git a/third_party/lisp/sclf/sclf.asd b/third_party/lisp/sclf/sclf.asd new file mode 100644 index 0000000000..a9754b7569 --- /dev/null +++ b/third_party/lisp/sclf/sclf.asd @@ -0,0 +1,58 @@ +;;; sclf.asd --- system definition + +;;; Copyright (C) 2005, 2006, 2008, 2009 by Walter C. Pelissero +;;; Copyright (C) 2021 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: SCLF + +#+cmu (ext:file-comment "$Module: sclf.asd, Time-stamp: <2013-06-17 15:32:29 wcp> $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :sclf-system + (:use :common-lisp :asdf #+asdfa :asdfa)) + +(in-package :sclf-system) + +(defsystem sclf + :name "SCLF" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + ;; :version "0.0" + :description "Stray Common Lisp Functions" + :long-description + "A collection of Common Lisp functions for the most disparate +uses, too small to fit anywhere else." + :licence "LGPL" + :depends-on (#+sbcl :sb-posix) + :components + ((:doc-file "README") + (:file "package") + (:file "sclf" :depends-on ("package")) + (:file "sysproc" :depends-on ("package" "sclf")) + (:file "lazy" :depends-on ("package" "sclf")) + (:file "time" :depends-on ("package" "sclf")) + (:file "directory" :depends-on ("package" "sclf" "time")) + (:file "serial" :depends-on ("package" "sclf")) + (:module "mp" + :depends-on ("package" "sclf") + :components + ((:doc-file "README") + (:file #.(first + (list #+cmu "cmu" + #+sbcl "sbcl" + "unknown"))))))) diff --git a/third_party/lisp/sclf/sclf.lisp b/third_party/lisp/sclf/sclf.lisp new file mode 100644 index 0000000000..dfbc2078c8 --- /dev/null +++ b/third_party/lisp/sclf/sclf.lisp @@ -0,0 +1,1717 @@ +;;; sclf.lisp --- miscellanea + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: SCLF + +#+cmu (ext:file-comment "$Module: sclf.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: + +;;; This is a collection of Common Lisp functions of the most disparate +;;; uses and purposes. These functions are too small or too unrelated +;;; to each other to deserve an own module. +;;; +;;; If you want to indent properly the following macros you should add +;;; the following lines to your .emacs file: +;;; +;;; (defun cl-indent-be (path state indent-point sexp-column normal-indent) +;;; (let ((sexp-start (cadr state)) +;;; (i 0)) +;;; (save-excursion +;;; (goto-char sexp-start) +;;; (forward-char) +;;; (+ sexp-column +;;; (block indentation +;;; (condition-case nil +;;; (while (< (point) indent-point) +;;; (setq i (1+ i)) +;;; (when (and (= 0 (logand i 1)) +;;; (looking-at "[\t\n ]*\\s(")) +;;; (return-from indentation 2)) +;;; (forward-sexp)) +;;; (error nil)) +;;; (if (= 1 (logand i 1)) +;;; 6 4)))))) +;;; +;;; (put 'be 'common-lisp-indent-function 'cl-indent-be) +;;; (put 'be* 'common-lisp-indent-function 'cl-indent-be) +;;; (put 'awhen 'lisp-indent-function 1) +;;; (put 'gcase 'lisp-indent-function 1) +;;; (put 'acase 'lisp-indent-function 1) +;;; (put 'acond 'lisp-indent-function 1) +;;; (put 'until 'lisp-indent-function 1) + + + +(cl:in-package :sclf) + +(defmacro be (&rest bindings-and-body) + "Less-parenthetic let." + (let ((bindings + (loop + while (and (symbolp (car bindings-and-body)) + (cdr bindings-and-body)) + collect (list (pop bindings-and-body) + (pop bindings-and-body))))) + `(let ,bindings + ,@bindings-and-body))) + +(defmacro be* (&rest bindings-and-body) + "Less-parenthetic let*." + (let ((bindings + (loop + while (and (symbolp (car bindings-and-body)) + (cdr bindings-and-body)) + collect (list (pop bindings-and-body) + (pop bindings-and-body))))) + `(let* ,bindings + ,@bindings-and-body))) + +(defmacro defconst (name value &rest etc) + "For some reason SBCL, between usefulness and adherence to the ANSI +standard, has chosen the latter, thus rendering the DEFCONSTANT pretty +useless. This macro works around that problem." + #+sbcl (list* 'defvar name value etc) + #-sbcl (list* 'defconstant name value etc)) + +(defmacro with-gensyms ((&rest symbols) &body body) + "Gensym all SYMBOLS and make them available in BODY. +See also LET-GENSYMS." + `(let ,(mapcar #'(lambda (s) + (list s '(gensym))) symbols) + ,@body)) + +(defun s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (be prefix-length (length prefix) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +(defun string-ends-with (postfix string &optional (compare #'string=)) + "Return true if STRING's last characters are the same as POSTFIX." + (be postfix-length (length postfix) + string-length (length string) + (and (>= string-length postfix-length) + (funcall compare postfix string :start2 (- string-length postfix-length))))) + +(defun string-substitute (from to sequence &key (start 0) end (test #'eql)) + "Replace in SEQUENCE occurrences of FROM with TO. FROM and TO don't +need to be the same length." + (be from-length (length from) + (with-output-to-string (out) + (write-string sequence out :start 0 :end start) + (loop + for position = (search from sequence :start2 start :end2 end :test test) + while position + do + (write-string sequence out :start start :end position) + (write-string to out) + (setf start (+ position from-length)) + finally (write-string (subseq sequence start) out))))) + +(defun string-escape (string character &key (escape-character #\\) (escape-escape t)) + "Prepend all occurences of CHARACTER in STRING with a +ESCAPE-CHARACTER." + (with-output-to-string (stream) + (loop + for c across string + when (or (char= c character) + (and escape-escape + (char= c escape-character))) + do (write-char escape-character stream) + do (write-char c stream)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro aif (test then &optional else) + `(be it ,test + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(be it ,test + (when it + ,@then))) + +(defmacro acond (&body forms) + (when forms + `(aif ,(caar forms) + (progn ,@(cdar forms)) + (acond ,@(cdr forms))))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro acase (condition &body forms) + `(be it ,condition + (case it ,@forms))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun string-trim-whitespace (string) + (string-trim +whitespace+ string)) + +(defun string-right-trim-whitespace (string) + (string-right-trim +whitespace+ string)) + +(defun string-left-trim-whitespace (string) + (string-left-trim +whitespace+ string)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(defun seq-whitespace-p (sequence) + (every #'whitespace-p sequence)) + +(defun not-empty (sequence) + "Return SEQUENCE if it's not empty, otherwise NIL. +NIL is indeed empty." + (when (or (listp sequence) + (not (zerop (length sequence)))) + sequence)) + +(defun position-any (bag sequence &rest position-args) + "Find any element of bag in sequence and return its position. +Accept any argument accepted by the POSITION function." + (apply #'position-if #'(lambda (element) + (find element bag)) sequence position-args)) + +(defun find-any (bag sequence &rest find-args) + "Find any element of bag in sequence. Accept any argument +accepted by the FIND function." + (apply #'find-if #'(lambda (element) + (find element bag)) sequence find-args)) + +(defun split-at (bag sequence &key (start 0) key) + "Split SEQUENCE at occurence of any element from BAG. +Contiguous occurences of elements from BAG are considered atomic; +so no empty sequence is returned." + (be len (length sequence) + (labels ((split-from (start) + (unless (>= start len) + (be sep (position-any bag sequence :start start :key key) + (cond ((not sep) + (list (subseq sequence start))) + ((> sep start) + (cons (subseq sequence start sep) + (split-from (1+ sep)))) + (t + (split-from (1+ start)))))))) + (split-from start)))) + +(defun split-string-at-char (string separator &key escape skip-empty) + "Split STRING at SEPARATORs and return a list of the substrings. If +SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is +not nil then split at SEPARATOR only if it's not preceded by ESCAPE." + (declare (type string string) (type character separator)) + (labels ((next-separator (beg) + (be pos (position separator string :start beg) + (if (and escape + pos + (plusp pos) + (char= escape (char string (1- pos)))) + (next-separator (1+ pos)) + pos))) + (parse (beg) + (cond ((< beg (length string)) + (let* ((end (next-separator beg)) + (substring (subseq string beg end))) + (cond ((and skip-empty (string= "" substring)) + (parse (1+ end))) + ((not end) + (list substring)) + (t + (cons substring (parse (1+ end))))))) + (skip-empty + '()) + (t + (list ""))))) + (parse 0))) + +(defun copy-stream (in out) + (loop + for c = (read-char in nil) + while c + do (write-char c out))) + +(defun pathname-as-file (pathname) + "Converts PATHNAME to file form and return it." + (unless (pathnamep pathname) + (setf pathname (pathname pathname))) + (cond ((pathname-name pathname) + pathname) + ((stringp (car (last (pathname-directory pathname)))) + (be name (parse-native-namestring (car (last (pathname-directory pathname)))) + (make-pathname :directory (butlast (pathname-directory pathname)) + :name (pathname-name name) + :type (pathname-type name) + :defaults pathname))) + ;; it can't be done? + (t pathname))) + +(defun copy-file (file copy-file &key (if-exists :error)) + (with-open-file (in file) + (with-open-file (out copy-file :direction :output :if-exists if-exists) + (copy-stream in out)))) + +(defun symlink-file (src dst &key (if-exists :error)) + (when (and (eq :supersede if-exists) + (probe-file dst)) + (delete-file dst)) + #+sbcl (sb-posix:symlink src dst) + #+cmu(unix:unix-symlink (native-namestring src) (native-namestring dst)) + #-(or sbcl cmu) (error "don't know how to symlink files")) + +(defun read-whole-stream (stream) + "Read stream until the end and return it as a string." + (with-output-to-string (string) + (loop + for line = (read-line stream nil) + while line + do (write-line line string)))) + +(defun read-lines (stream &optional n) + "Read N lines from stream and return them as a list of strings. If +N is NIL, read the whole stream til the end. If the stream ends +before N lines a read, this function will return those without +signalling an error." + (loop + for line = (read-line stream nil) + for i from 0 + while (and line + (or (not n) + (< i n))) + collect line)) + +(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (in pathname + :element-type element-type + :if-does-not-exist (unless (eq :value if-does-not-exist) + :error)) + (if in + (be seq (make-array (file-length in) :element-type element-type) + (read-sequence seq in) + seq) + default))) + +(defun write-file (pathname contents &key (if-exists :error)) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (out pathname + :element-type (if (stringp contents) + 'character + (array-element-type contents)) + :if-exists if-exists) + (write-sequence contents out))) + +(defun read-from-file (pathname &key (on-error :error) default) + "Similar to READ-FROM-STRING but for files. Read the first Lisp +object in file and return it. If file does not exist or does not +contain a readable Lisp object, ON-ERROR tells what to do. If +ON-ERROR is :ERROR, an error is signalled. If ON-ERROR is :VALUE, +DEFAULT is returned." + (ecase on-error + (:error + (with-open-file (in pathname) + (read in))) + (:value + (handler-case (with-open-file (in pathname) + (read in)) + (t () + default))))) + +(defun write-to-file (object pathname &key (if-exists :error) pretty) + "Similar to WRITE-TO-STRING but for files. Write OBJECT to a file +with pathname PATHNAME." + (with-open-file (out pathname :direction :output :if-exists if-exists) + (write object :stream out :escape t :readably t :pretty pretty))) + +(defun string-concat (list &optional (separator "")) + "Concatenate the strings in LIST interposing SEPARATOR (default +nothing) between them." + (reduce #'(lambda (&rest args) + (if args + (s+ (car args) separator (cadr args)) + "")) + list)) + +;; to indent it properly: (put 'gcase 'lisp-indent-function 1) +(defmacro gcase ((value &optional (test 'equalp)) &rest cases) + "Generic CASE macro. Match VALUE to CASES as if by the normal CASE +but use TEST as the comparison function, which defaults to EQUALP." + (with-gensyms (val) + `(be ,val ,value + ,(cons 'cond + (mapcar #'(lambda (case-desc) + (destructuring-bind (vals &rest forms) case-desc + `(,(cond ((consp vals) + (cons 'or (mapcar #'(lambda (v) + (list test val v)) + vals))) + ((or (eq vals 'otherwise) + (eq vals t)) + t) + (t (list test val vals))) + ,@forms))) + cases))))) + +(defun string-truncate (string max-length) + "If STRING is longer than MAX-LENGTH, return a shorter version. +Otherwise return the same string unchanged." + (if (> (length string) max-length) + (subseq string 0 max-length) + string)) + +;; to indent properly: (put 'until 'lisp-indent-function 1) +(defmacro until (test &body body) + (with-gensyms (result) + `(loop + for ,result = ,test + until ,result + do (progn ,@body) + finally (return ,result)))) + +(defun keywordify (string) + (intern (string-upcase string) :keyword)) + +(defun locate-system-program (name) + "Given the NAME of a system program try to find it through the +search of the environment variable PATH. Return the full +pathname." + (loop + for dir in (split-string-at-char (getenv "PATH") #\:) + for pathname = (merge-pathnames name (pathname-as-directory dir)) + when (probe-file pathname) + return pathname)) + +(defvar *tmp-file-defaults* #P"/tmp/") + +(defun temp-file-name (&optional (default *tmp-file-defaults*)) + "Create a random pathname based on DEFAULT. No effort is made +to make sure that the returned pathname doesn't identify an +already existing file. If missing DEFAULT defaults to +*TMP-FILE-DEFAULTS*." + (make-pathname :defaults default + :name (format nil "~36R" (random #.(expt 36 10))))) + +(defun open-temp-file (&optional default-pathname &rest open-args) + "Open a new temporary file and return a stream to it. This function +makes sure the pathname of the temporary file is unique. OPEN-ARGS +are arguments passed verbatim to OPEN. If OPEN-ARGS specify +the :DIRECTION it should be either :OUTPUT (default) or :IO; +any other value causes an error. If DEFAULT-PATHNAME is specified and +not NIL it's used as defaults to produce the pathname of the temporary +file, otherwise *TMP-FILE-DEFAULTS* is used." + (unless default-pathname + (setf default-pathname *tmp-file-defaults*)) + ;; if :DIRECTION is specified check that it's compatible with the + ;; purpose of this function, otherwise make it default to :OUTPUT + (aif (getf open-args :direction) + (unless (member it '(:output :io)) + (error "Can't create temporary file with open direction ~A." it)) + (setf open-args (append '(:direction :output) + open-args))) + (do* ((name #1=(temp-file-name default-pathname) #1#) + (stream #2=(apply #'open name + :if-exists nil + :if-does-not-exist :create + open-args) #2#)) + (stream stream))) + +(defmacro with-temp-file ((stream &rest open-temp-args) &body body) + "Execute BODY within a dynamic extent where STREAM is bound to +a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are +passed verbatim to OPEN-TEMP-FILE." + `(be ,stream (open-temp-file ,@open-temp-args) + (unwind-protect + (progn ,@body) + (close ,stream) + ;; body may decide to rename the file so we must ignore the errors + (ignore-errors + (delete-file (pathname ,stream)))))) + +(defmacro with-hidden-temp-file ((stream &rest open-args) &body body) + "Just like WITH-TEMP-FILE but unlink (delete) the temporary file +before the execution of BODY. As such BODY won't be able to +manipulate the file but through STREAM, and no other program is able +to see it. Once STREAM is closed the temporary file blocks are +automatically relinquished by the operating system. This works at +least on Unix filesystems. I don't know about MS-OSs where the system +may likely decide to crash, take all your data with it and, in the +meanwhile, report you to the NSA as terrorist." + `(be ,stream (open-temp-file ,@open-args) + (unwind-protect + (progn (delete-file (pathname ,stream)) + ,@body) + (close ,stream)))) + +(defun insert-in-order (item seq &key (test #'<) key) + "Destructively insert ITEM in LIST in order by TEST. Return +the new list. This is a simple wrapper around MERGE." + (merge (if seq + (type-of seq) + 'list) + (list item) seq test :key key)) + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +(defun soundex (word &optional (key-length 4)) + "Knuth's Soundex algorithm. Returns a string representing the +sound of a certain word (English). Different words will thus +yield the same output string. To compare two string by the +sound, simply do: + + (string= (soundex str1) (soundex str2)) + +Examples: + + (soundex \"Knuth\") => \"K530\" + (soundex \"Kant\") => \"K530\" + (soundex \"Lloyd\") => \"L300\" + (soundex \"Ladd\") => \"L300\"" + (declare (type string word)) + (flet ((translate-char (char) + (awhen (position char "BFPVCGJKQSXZDTLMNR") + (elt "111122222222334556" it)))) + (let ((key (make-string key-length :initial-element #\0)) + (word-length (length word))) + (setf (elt key 0) (elt word 0)) + (loop + with previous-sound = (translate-char (char-upcase (elt word 0))) + with j = 1 + for i from 1 by 1 below word-length + for c = (char-upcase (elt word i)) + while (< j key-length) + do (be sound (translate-char c) + (cond ((not (eq sound previous-sound)) + (unless (member c '(#\H #\W)) + (setf previous-sound sound)) + (when sound + (setf (elt key j) sound) + (incf j)))))) + key))) + +(defun string-soundex= (string1 string2) + (let ((l1 (split-at +whitespace+ string1)) + (l2 (split-at +whitespace+ string2))) + (and (= (length l1) (length l2)) + (every #'string= (mapcar #'soundex l1) (mapcar #'soundex l2))))) + +#+(OR) +(defun soundex-test () + (let* ((words1 '("Euler" "Gauss" "Hilbert" "Knuth" "Lloyd" "Lukasiewicz" "Wachs")) + (words2 '("Ellery" "Ghosh" "Heilbronn" "Kant" "Ladd" "Lissajous" "Waugh")) + (results '("E460" "G200" "H416" "K530" "L300" "L222" "W200"))) + (mapc #'(lambda (w1 w2 r) + (let ((r1 (soundex w1)) + (r2 (soundex w2))) + (format t "~A = ~A, ~A = ~A => ~A~%" w1 r1 w2 r2 + (if (and (string= r1 r2) + (string= r r1)) + "OK" + (format nil "ERROR (expected ~A)" r))))) + words1 words2 results) + (values))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defstruct cache-slot () +;; ((previous :type (or cache-slot null) +;; :initarg :previous +;; :initform nil +;; :accessor cslot-previous) +;; (key :initarg :key +;; :accessor cslot-key) +;; (value :initarg :value +;; :accessor cslot-value) +;; (next :type (or cache-slot null) +;; :initarg :next +;; :initform nil +;; :accessor cslot-next))) + +;; (defmethod print-object ((object cache-slot) stream) +;; (print-unreadable-object (object stream :type t) +;; (if (slot-boundp object 'key) +;; (format stream "key=~S, value=~S" (cslot-key object) (cslot-value object)) +;; (format stream "NULL")))) + + +(defstruct (double-linked-element (:conc-name dle-)) + (previous nil :type (or double-linked-element null)) + value + (next nil :type (or double-linked-element null))) + +(defmethod print-object ((object double-linked-element) stream) + (print-unreadable-object (object stream :type t) + (format stream "value=~S" (dle-value object)))) + +(defun cons-dle (value previous next) + (declare (type (or double-linked-element null) previous next)) + (be new-element (make-double-linked-element :previous previous :next next :value value) + (when previous + (setf (dle-next previous) new-element)) + (when next + (setf (dle-previous next) new-element)) + new-element)) + +(defun dle-remove (dle-object) + "Remove the DLE-OBJECT from its current position in the list of +elements agjusting the pointer of dle-objects before and after this +one (if any)." + (declare (type double-linked-element dle-object)) + (awhen (dle-next dle-object) + (setf (dle-previous it) (dle-previous dle-object))) + (awhen (dle-previous dle-object) + (setf (dle-next it) (dle-next dle-object)))) + +(defun dle-map (function dle-object) + (when dle-object + (make-double-linked-element :value (funcall function (dle-value dle-object)) + :previous (dle-previous dle-object) + :next (dle-map function (dle-next dle-object))))) + +(defmacro do-dle ((var dle &optional (result nil)) &body body) + "Iterate over a list of DOUBLE-LINKED-ELEMENTs and map body to +each element's value. Bind VAR to the value on each iteration." + (be cursor (gensym) + `(do ((,cursor ,dle (dle-next ,cursor))) + ((not ,cursor) ,result) + (be ,var (dle-value ,cursor) + ,@body)))) + +(defmacro do-dle* ((var dle &optional (result nil)) &body body) + "Same as DO-DLE but VAR is a symbol macro, so that BODY can +modify the element's value." + (be cursor (gensym) + `(symbol-macrolet ((,var (dle-value ,cursor))) + (do ((,cursor ,dle (dle-next ,cursor))) + ((not ,cursor) ,result) + ,@body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass double-linked-list () + ((elements :type double-linked-element + :documentation "The actual list of elements held by this object.") + (last-element :type double-linked-element)) + (:documentation + "A double linked list where elements can be added or removed +from either end.")) + +(defmethod initialize-instance ((object double-linked-list) &rest rest) + (declare (ignorable rest)) + (call-next-method) + (with-slots (last-element elements) object + (setf last-element (make-double-linked-element) + elements last-element))) + +(defmethod print-object ((object double-linked-list) stream) + (print-unreadable-object (object stream :type t) + (be elements '() + (do-dle (e (slot-value object 'elements)) + (push e elements)) + (format stream "elements=~S" (nreverse elements))))) + +(defgeneric pop-first (double-linked-list) + (:documentation + "Pop the first element of a double-linked-list.")) +(defgeneric pop-last (double-linked-list) + (:documentation + "Pop the last element of a double-linked-list.")) +(defgeneric push-first (item double-linked-list) + (:documentation + "Push an item in front of a double-linked-list.")) +(defgeneric push-last (item double-linked-list) + (:documentation + "Append an item to a double-linked-list.")) +(defgeneric list-map (function double-linked-list) + (:documentation + "Map a function to a double-linked-list.")) +(defgeneric dll-find-cursor (object dll &key test key)) +(defgeneric dll-find (object dll &key test key)) +(defgeneric dll-remove (cursor dll)) + +(defmethod pop-last ((list double-linked-list)) + "Drop the last element in the dl list." + (with-slots (last-element) list + (awhen (dle-previous last-element) + (dle-remove it) + (dle-value it)))) + +(defmethod pop-first ((list double-linked-list)) + "Drop the first element in the dl list." + (with-slots (elements) list + (when (dle-next elements) + (prog1 (dle-value elements) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))))) + +(defmethod push-first (value (list double-linked-list)) + (with-slots (elements) list + (setf elements (cons-dle value nil elements))) + list) + +(defmethod push-last (value (list double-linked-list)) + (with-slots (last-element) list + (cons-dle value (dle-previous last-element) last-element)) + list) + +(defmethod list-map (function (list double-linked-list)) + (labels ((map-dll (dle) + (when (dle-next dle) + (make-double-linked-element + :value (funcall function (dle-value dle)) + :previous (dle-previous dle) + :next (map-dll (dle-next dle)))))) + (map-dll (slot-value list 'elements)))) + +(defmethod dll-find-cursor (object (list double-linked-list) &key (test #'eql) (key #'identity)) + (do ((cursor (slot-value list 'elements) (dle-next cursor))) + ((not (dle-next cursor))) + (be value (dle-value cursor) + (when (funcall test (funcall key value) object) + (return cursor))))) + +(defmethod dll-find (object (list double-linked-list) &key (test #'eql) (key #'identity)) + (awhen (dll-find-cursor object list :test test :key key) + (dle-value it))) + +(defmethod dll-remove ((cursor double-linked-element) (list double-linked-list)) + (with-slots (elements) list + (if (dle-previous cursor) + (dle-remove cursor) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))) + list) + +(defmacro do-dll ((var list &optional (result nil)) &body body) + "Iterate over a dll and map body to each element's +value. Bind VAR to the value on each iteration." + (be cursor (gensym) + `(do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) + ((not (dle-next ,cursor)) ,result) + (be ,var (dle-value ,cursor) + ,@body)))) + +(defmacro do-dll* ((var list &optional (result nil)) &body body) + "Same as DO-DLL but VAR is a symbol macro, so that BODY can +modify the element's value." + (be cursor (gensym) + `(symbol-macrolet ((,var (dle-value ,cursor))) + (do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) + ((not (dle-next ,cursor)) ,result) + ,@body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass limited-list (double-linked-list) + ((max-size :initform nil + :initarg :size + :reader max-size + :type (or integer null) + :documentation "Size limit to which the list is allowed to grow to. NIL = no limit.") + (size :initform 0 + :reader size + :type integer + :documentation "Current number of elements in the list.")) + (:documentation + "A double linked list where the maximum number of elements can +be limited.")) + +(defun dll-member-p (dle list) + (with-slots (elements size) list + (do ((e elements (dle-next e))) + ((not e)) + (when (eq e dle) + (return t))))) + +(defmethod dll-remove ((cursor double-linked-element) (list limited-list)) + (with-slots (size) list + (unless (zerop size) + (decf size) + (call-next-method))) + list) + +(defmethod pop-first ((list limited-list)) + (with-slots (size) list + (unless (zerop size) + (decf size) + (call-next-method)))) + +(defmethod pop-last ((list limited-list)) + (with-slots (size) list + (unless (zerop size) + (decf size) + (call-next-method)))) + +(defmethod push-first (value (list limited-list)) + "Add in front of the list and drop the last element if list is +full." + (declare (ignore value)) + (prog1 (call-next-method) + (with-slots (max-size size last-element) list + (if (or (not max-size) + (< size max-size)) + (incf size) + (dle-remove (dle-previous last-element)))))) + +(defmethod push-last (value (list limited-list)) + "Add at the end of the list and drop the first element if list +is full." + (declare (ignore value)) + (prog1 (call-next-method) + (with-slots (max-size size elements) list + (if (or (not max-size) + (< size max-size)) + (incf size) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass sorted-list (limited-list) + ((test :type function + :initarg :test)) + (:documentation + "A double linked list where elements are inserted in a +sorted order.")) + +(defgeneric insert (item sorted-list) + (:documentation + "Insert an item in a sorted-list.")) + +(defmethod insert (item (sl sorted-list)) + "Insert ITEM in SL, which is a sorted double linked list, +before the item for which TEST is true or at the end of the list. +Returns two values, the modified list and the cursor to the new +element." + (with-slots (max-size size elements test last-element) sl + (do ((cursor elements (dle-next cursor))) + ((or (not (dle-next cursor)) + (funcall test item (dle-value cursor))) + (if (dle-previous cursor) + (cons-dle item (dle-previous cursor) cursor) + (setf elements (cons-dle item nil cursor))) + (if (or (not max-size) + (< size max-size)) + (incf size) + (dle-remove (dle-previous last-element))) + (values sl (dle-previous cursor)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass heap () + ((less-than :type function + :initarg :test + :documentation "The heap invariant.") + (data :type array + :documentation "The heap tree representation."))) + +(defmethod initialize-instance ((heap heap) &rest args) + (declare (ignore args)) + (call-next-method) + (with-slots (data) heap + (setf data (make-array 0 :fill-pointer 0 :adjustable t)))) + +(defgeneric heap-add (heap item)) + +(defun bubble-up (heap pos) + (with-slots (data less-than) heap + (loop + for current = pos then parent + for parent = (truncate (1- current) 2) + until (or (zerop current) + (funcall less-than (aref data parent) (aref data current))) + do (rotatef (aref data current) (aref data parent))))) + +(defmethod heap-add ((heap heap) item) + (with-slots (data) heap + (vector-push-extend item data) + (bubble-up heap (1- (fill-pointer data))))) + +(defgeneric heap-size (heap)) + +(defmethod heap-size ((heap heap)) + (fill-pointer (slot-value heap 'data))) + +(defgeneric heap-empty-p (heap)) + +(defmethod heap-empty-p ((heap heap)) + (zerop (heap-size heap))) + + +(defgeneric heap-pop (heap)) + +(defun percolate-down (heap pos) + (with-slots (data less-than) heap + (loop + with end = (fill-pointer data) + for current = pos then child + for left-child = (+ 1 (* 2 current)) + for right-child = (+ 2 (* 2 current)) + for child = (cond ((>= left-child end) + (return)) + ((>= right-child end) + left-child) + ((funcall less-than (aref data left-child) (aref data right-child)) + left-child) + (t + right-child)) + while (funcall less-than (aref data child) (aref data current)) + do (rotatef (aref data current) (aref data child))))) + +(defmethod heap-pop ((heap heap)) + (assert (not (heap-empty-p heap))) + (with-slots (data) heap + (be root (aref data 0) + (setf (aref data 0) (vector-pop data)) + (percolate-down heap 0) + root))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (lru-cache-slot (:include double-linked-element) + (:conc-name lruc-slot-)) + key) + +(defmethod print-object ((object lru-cache-slot) stream) + (print-unreadable-object (object stream :type t) + (format stream "key=~S value=~S" (lruc-slot-key object) (lruc-slot-value object)))) + +(defvar *default-cache-size* 100 + "Default size of a LRU cache if it's not specified at instantiation +time.") + +(defclass lru-cache () + ((max-size :initform *default-cache-size* + :initarg :size + :reader max-size + :type (or integer null) + :documentation + "Maximum number of elements that the cache can fit.") + (elements-list :type lru-cache-slot + :documentation "The list of elements held by the cache.") + (elements-hash :type hash-table + :documentation "The hash table of the elements held bye the cache.") + (last-element :type lru-cache-slot) + (size :initform 0 + :reader size + :type integer + :documentation "Current number of elements in the cache.") + (finalizer :initform nil + :initarg :finalizer + :documentation + "Procedure to call when elements are dropped from cache.")) + (:documentation + "An objects cache that keeps the elements used more often and +drops those that are used less often. The usage is similar to an +hash table. Elements are added to the list up to MAX-SIZE, then +any new element will drop the less used one in the cache. Every +time an element is set or retrieved it goes in front of a list. +Those which get at the end of the list are dropped when more room +is required.")) + +(defmethod initialize-instance ((object lru-cache) &key test &allow-other-keys) + (call-next-method) + (with-slots (last-element elements-list elements-hash) object + (setf last-element (make-lru-cache-slot) + elements-list last-element + elements-hash (if test + (make-hash-table :test test) + (make-hash-table))))) + +(defgeneric getcache (key cache) + (:documentation + "Get an item with KEY from a CACHE.")) + +(defgeneric (setf getcache) (value key cache) + (:documentation + "Set or add an item with KEY in a CACHE.")) + +(defgeneric remcache (key cache) + (:documentation + "Remove an item with KEY from a CACHE.")) + +(defun move-in-front-of-cache-list (slot cache) + "Relocate slot to the front of the elements list in cache. +This will stretch its lifespan in the cache." + (declare (type lru-cache-slot slot) + (type lru-cache cache)) + (with-slots (elements-list) cache + ;; unless it's already the first + (unless (eq slot elements-list) + ;; remove the slot from its original place... + (dle-remove slot) + ;; ... and add it in front of the list + (setf (lruc-slot-next slot) elements-list + (lruc-slot-previous slot) nil + (lruc-slot-previous elements-list) slot + elements-list slot)))) + +(defun drop-last-cache-element (cache) + "Drop the last element in the list of the cache object." + (declare (type lru-cache cache)) + (with-slots (last-element elements-hash finalizer) cache + (let ((second-last (lruc-slot-previous last-element))) + (assert second-last) + (when finalizer + (funcall finalizer (lruc-slot-value second-last))) + (dle-remove second-last) + (remhash (lruc-slot-key second-last) elements-hash)))) + +(defun add-to-cache (slot cache) + (declare (type lru-cache-slot slot) + (type lru-cache cache)) + (move-in-front-of-cache-list slot cache) + (with-slots (max-size size elements-hash) cache + (setf (gethash (lruc-slot-key slot) elements-hash) slot) + (if (and max-size + (< size max-size)) + (incf size) + (drop-last-cache-element cache)))) + +(defmethod getcache (key (cache lru-cache)) + (multiple-value-bind (slot found?) (gethash key (slot-value cache 'elements-hash)) + (when found? + (move-in-front-of-cache-list slot cache) + (values (lruc-slot-value slot) t)))) + +(defmethod (setf getcache) (value key (cache lru-cache)) + (with-slots (elements-hash elements-list) cache + (multiple-value-bind (slot found?) (gethash key elements-hash) + (if found? + (progn + (move-in-front-of-cache-list slot cache) + (setf (lruc-slot-value slot) value)) + (add-to-cache (make-lru-cache-slot :key key :value value) cache)) + value))) + +(defmethod remcache (key (cache lru-cache)) + (with-slots (elements-hash size elements-list finalizer) cache + (multiple-value-bind (slot found?) (gethash key elements-hash) + (when found? + (remhash key elements-hash) + (when finalizer + (funcall finalizer (lruc-slot-value slot))) + (when (eq slot elements-list) + (setf elements-list (dle-next slot))) + (dle-remove slot) + (decf size) + t)))) + +(defmacro cached (cache key value) + "If KEY is found in CACHE return the associated object. Otherwise +store VALUE for later re-use." + (with-gensyms (object my-cache my-key my-value found?) + `(let* ((,my-cache ,cache) + (,my-key ,key)) + (multiple-value-bind (,object ,found?) (getcache ,my-key ,my-cache) + (if ,found? + ,object + (let ((,my-value ,value)) + (setf (getcache ,my-key ,my-cache) ,my-value) + ,my-value)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(declaim (inline list->string)) +(defun list->string (list) + "Coerce a list of characters into a string." + (coerce list 'string)) + +(defun setuid (id) + "Set the Unix real user id." + (when (stringp id) + (setf id (find-uid id))) + #+sbcl (sb-posix:setuid id) + #+cmu (unix:unix-setuid id) + #+clisp (posix::%setuid id) ; not verified -wcp26/8/09. + #-(or cmu sbcl clisp) + (error "setuid unsupported under this Lisp implementation")) + +(defun seteuid (id) + "Set the Unix effective user id." + (when (stringp id) + (setf id (find-uid id))) + #+sbcl (sb-posix:seteuid id) + #+cmu (unix:unix-setreuid -1 id) + #+clisp (posix::%seteuid id) ; not verified -wcp26/8/09. + #-(or cmu sbcl clisp) + (error "seteuid unsupported under this Lisp implementation")) + +(defun find-uid (name) + "Find the user id of NAME. Return an integer." + #+sbcl (awhen (sb-posix:getpwnam name) + (sb-posix:passwd-uid it)) + #+cmu (awhen (unix:unix-getpwnam name) + (unix:user-info-uid it)) + #-(or cmu sbcl) + (error "Unable to find a UID on this Lisp system.")) + +#+clisp (ffi:def-call-out %getuid + (:name "getuid") + (:arguments) + (:return-type ffi:int) + (:library "libc.so")) + +(defun getuid () + "Return the Unix user id. This is an integer." + #+sbcl (sb-unix:unix-getuid) + #+cmu (unix:unix-getuid) + #+clisp (%getuid) + #-(or cmu sbcl clisp) + (error "getuid unsupported under this Lisp implementation")) + +(defun super-user-p (&optional id) + "Return true if the user ID is zero. ID defaults to the current +user id." + (zerop (or id (getuid)))) + +(defmacro with-euid (uid &body forms) + "Switch temporarely to Unix user id UID, while performing FORMS." + (with-gensyms (ruid) + `(be ,ruid (getuid) + (seteuid ,uid) + (unwind-protect (progn ,@forms) + (seteuid ,ruid))))) + +(defun get-logname (&optional uid) + "Return the login id of the user. This is a string and it is not +the Unix uid, which is a number." + (unless uid + (setf uid (getuid))) + (when (stringp uid) + (setf uid (find-uid uid))) + (when uid + #+sbcl (sb-unix:uid-username uid) + #+cmu (unix:user-info-name (unix:unix-getpwuid uid)) + #+clisp (posix:user-info-login-id (posix:user-info uid)) + #-(or cmu sbcl clisp) + (error "get-logname unsupported under this Lisp implementation"))) + +(defun get-user-name (&optional uid) + "Return the user name, taken from the GCOS field of the /etc/passwd +file." + (unless uid + (setf uid (getuid))) + (when (stringp uid) + (setf uid (find-uid uid))) + (when uid + (car (split-string-at-char #+cmu (unix:user-info-gecos (unix:unix-getpwuid uid)) + #+sbcl (sb-posix:passwd-gecos (sb-posix:getpwuid uid)) + #-(or cmu sbcl) (error "can't getpwuid() on this Lisp system.") + #\,)))) + +(defun get-user-home (&optional uid) + (unless uid + (setf uid (getuid))) + (when (stringp uid) + (setf uid (find-uid uid))) + (when uid + #+cmu (unix:user-info-dir (unix:unix-getpwuid uid)) + #+sbcl (sb-posix:passwd-dir (sb-posix:getpwuid uid)))) + +;; Rather stupid, but the mnemonic is worth it +(declaim (inline alist->plist)) +(defun alist->plist (alist) + "Convert an association list into a property list. The alist +elements are assumed to be lists of just two elements: the key +and the value. If the element list is longer this function +doesn't work." + (mapcan #'identity alist)) + +(defun plist->alist (plist &optional pairs-p) + "Convert a property list into an association list. The alist +elements wiil be lists of just two elements: the key and the +value. If PAIRS-P is true the alist elements will be pairs." + (loop + for (key val) on plist by #'cddr + collect (if pairs-p + (cons key val) + (list key val)))) + +(defun string->byte-vector (string &key start end) + "Convert a string of characters into a vector of (unsigned-byte +8) elements." + (map '(vector (unsigned-byte 8)) #'char-code + (if (or start end) + (subseq string (or start 0) end) + string))) + +(defun byte-vector->string (vector &key start end) + "Convert a vector of (unsigned-byte 8) elements into a string +of characters." + (map 'string #'code-char + (if (or start end) + (subseq vector (or start 0) end) + vector))) + +(defun outdated-p (file dependencies) + "Check if FILE has been modified before any of its +DEPENDENCIES." + (be epoch (and (probe-file file) + (file-write-date file)) + ;; if file is missing altogether, we consider it outdated + (or (not epoch) + (loop + for dep in dependencies + thereis (aand (probe-file dep) + (file-write-date dep) + (> it epoch)))))) + +(defmacro let-places (places-and-values &body body) + "Execute BODY binding temporarily some places to new values and +restoring the original values of these places on exit of BODY. The +syntax of this macro is identical to LET. The difference is that +instead of new variable names this macro binds values to existing +places (variables)." + (be tmp-variables (loop for x in places-and-values collect (gensym)) + `(let ,(mapcar #'(lambda (tmp-var place-and-value) + (list tmp-var (car place-and-value))) + tmp-variables places-and-values) + (unwind-protect + (progn + ;; as some assignments could signal an error, we assign + ;; within the unwind-protect block so that we can always + ;; guarantee a consistent state on exit + ,@(mapcar #'(lambda (place-and-value) + `(setf ,(car place-and-value) ,(cadr place-and-value))) + places-and-values) + ,@body) + ,@(mapcar #'(lambda (tmp-var place-and-value) + `(setf ,(car place-and-value) ,tmp-var)) + tmp-variables + places-and-values))))) + +(defmacro let-slots (accessor/new-value-pairs object &body body) + "Execute BODY with some OBJECT's slots temporary sets to new +values as described in ACCESSOR/NEW-VALUE-PAIRS. The latter +should be an alist of accessor names and the value to be assigned +to that slot. On exit from BODY, those slots are restored to +their original value. See LET-PLACES." + (with-gensyms (obj) + `(be ,obj ,object + (let-places ,(mapcar #'(lambda (av) + `((,(car av) ,obj) ,(cadr av))) + accessor/new-value-pairs) + ,@body)))) + +(defvar *decimal-point* #\.) +(defvar *thousands-comma* #\,) + +(defun format-amount (number &key (decimals 2) (rounder #'round) + (comma *thousands-comma*) (comma-stance 3) + (decimal-point *decimal-point*)) + "Return a string formatted as fixed decimal point number of DECIMALS +adding commas every COMMA-STANCE places before the decimal point." + (declare (type number number) + (type fixnum decimals comma-stance) + (type function rounder) + (type character comma decimal-point) + (optimize (speed 3) (safety 0) (debug 0))) + (let* ((int (funcall rounder (* number (expt 10 decimals)))) + (negative (< int 0))) + (declare (integer int)) + (when negative + (setf int (- int))) + (let* ((digits (max (1+ decimals) + (1+ (if (zerop int) + 0 + (truncate (log int 10)))))) + (string-length (+ digits + ;; the minus sign + (if negative 1 0) + ;; the decimal point + (if (zerop decimals) 0 1) + ;; the thousands commas + (1- (ceiling (- digits decimals) comma-stance)))) + (string (make-string string-length)) + (pos (1- string-length))) + (declare (type fixnum pos digits)) + (labels ((add-char (char) + (setf (schar string pos) char) + (decf pos)) + (add-digit () + (add-char (digit-char (mod int 10))) + (setf int (truncate int 10)))) + (unless (zerop decimals) + (loop + for i fixnum from 0 below decimals + do (add-digit)) + (add-char decimal-point)) + (loop + for i fixnum from 1 + do (add-digit) + while (>= pos (if negative 1 0)) + when (zerop (mod i comma-stance)) + do (add-char comma)) + (when negative + (add-char #\-))) + string))) + +(defun parse-amount (string &key (start 0) end) + "Parse STRING as if it was formatted with FORMAT-AMOUNT and return +the parsed number. Return NIL if STRING is malformed. Leading or +trailing spaces must be removed from the string in advance." + (loop + with amount = 0 + with decimals = nil + with negative = (when (and (not (zerop (length string))) + (char= #\- (char string 0))) + (incf start) + t) + for i from start below (or end (length string)) + for c = (char string i) + do (cond ((char= c *decimal-point*) + (if decimals + (return nil) + (setf decimals 0))) + ((char= c *thousands-comma*)) + (t + (be d (digit-char-p c) + (cond ((not d) + (return nil)) + (decimals + (incf decimals) + (incf amount (/ d (expt 10 decimals)))) + (t + (setf amount (+ d (* amount 10)))))))) + finally (return (if negative + (- amount) + amount)))) + +(defmacro with-package (name &body body) + `(let ((*package* (find-package ,name))) + ,@body)) + +(defun bytes-simple-string (n &optional imply-bytes) + "Return a string describing N using a unit of measure multiple +of a byte that is most apporpriate for the magnitude of N. A +kilobyte is 1024 not 1000 bytes, everything follows." + (let* ((kilo 1024) + (mega (* kilo kilo)) + (giga (* kilo mega)) + (tera (* mega mega)) + (peta (* kilo tera))) + (apply #'format nil "~,1F~A" + (cond ((> n (* 2 peta)) + (list (/ n peta) (if imply-bytes "P" "PB"))) + ((> n (* 2 tera)) + (list (/ n tera) (if imply-bytes "T" "TB"))) + ((> n (* 2 giga)) + (list (/ n giga) (if imply-bytes "G" "GB"))) + ((> n (* 2 mega)) + (list (/ n mega) (if imply-bytes "M" "MB"))) + ((> n (* 2 kilo)) + (list (/ n kilo) (if imply-bytes "K" "KB"))) + (t (list n (if imply-bytes "" " bytes"))))))) + +;; WARNING: This function may or may not work on your Lisp system. It +;; all depends on how the OPEN function has been implemented regarding +;; the :IF-EXISTS option. This function requires that OPEN be +;; implemented in a way so that the checking of the existence of file +;; and its open attempt be atomic. If the Lisp OPEN first checks that +;; the file exists and then tries to open it, this function won't be +;; reliable. CMUCL seems to use the O_EXCL open() flag in the right +;; way. So at least on CMUCL this function will work. Same goes for +;; SBCL. +(defun make-lock-files (pathnames &key (sleep-time 7) retries (suspend 13) expiration) + "Create semaphore files. If it can't create all the specified +files in the specified order, it waits SLEEP-TIME seconds and +retries the last file that didn't succeed. You can specify the +number of RETRIES to do until failure is returned. If the number +of retries is NIL this function will retry forever. + +If it tries RETRIES times without success, this function signal +an error and removes all the lock files it created until then. + +All files created by lock file will be read-only. + +If you specify a EXPIRATION then an existing lock file will be +removed by force after EXPIRATION seconds have passed since the +lock file was last modified/created (most likely by some other +program that unexpectedly died without cleaning up its lock +files). After a lock file has been removed by force, a +suspension of SUSPEND seconds is taken into account, in order to +prevent the inadvertent immediate removal of any newly created +lock file by another program." + (be locked '() + (flet ((lock (file) + (when (and expiration + (> (get-universal-time) + (+ (file-write-date file) expiration))) + (delete-file file) + (when suspend + (sleep suspend))) + (do ((i 0 (1+ i)) + (done nil)) + (done) + (unless (or (not retries) + (< i retries)) + (error "Can't create lock file ~S: tried ~A time~:P." file retries)) + (with-open-file (out file :direction :output :if-exists nil) + (cond (out + (format out "Lock file created on ~A~%" (time-string (get-universal-time))) + (setf done t)) + (sleep-time + (sleep sleep-time))))))) + (unwind-protect + (progn + (dolist (file pathnames) + (lock file) + (push file locked)) + (setf locked '())) + (mapc #'delete-file locked))))) + +(defmacro with-lock-files ((lock-files &rest lock-args) &body body) + "Execute BODY after creating LOCK-FILES. Remove the lock files +on exit. LOCK-ARGS are passed to MAKE-LOCK-FILES." + (with-gensyms (files) + `(be ,files (list ,@lock-files) + (make-lock-files ,files ,@lock-args) + (unwind-protect (progn ,@body) + (mapc #'delete-file ,files))))) + +(defun getpid () + #+cmu (unix:unix-getpid) + #+sbcl (sb-unix:unix-getpid) + #+clisp (ext:process-id) + #-(or cmu sbcl clisp) + (error "getpid unsupported under this Lisp implementation")) + +(defmacro on-error (form &body error-forms) + "Execute FORM and in case of error execute ERROR-FORMS too. +This does _not_ stop the error from propagating." + (be done-p (gensym) + `(be ,done-p nil + (unwind-protect + (prog1 + ,form + (setf ,done-p t)) + (unless ,done-p + ,@error-forms))))) + +(defun floor-to (x aim) + "Round X down to the nearest multiple of AIM." + (* (floor x aim) aim)) + +(defun round-to (x aim) + "Round X to the nearest multiple of AIM." + (* (round x aim) aim)) + +(defun ceiling-to (x aim) + "Round X up to the nearest multiple of AIM." + (* (ceiling x aim) aim)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct queue + first + last) + +(defgeneric queue-append (queue objects)) +(defgeneric queue-pop (queue)) +(defgeneric queue-empty-p (queue)) + +(defmethod queue-append ((queue queue) (objects list)) + (cond ((null (queue-first queue)) + (setf (queue-first queue) objects + (queue-last queue) (last objects))) + (t + (setf (cdr (queue-last queue)) objects + (queue-last queue) (last objects)))) + queue) + +(defmethod queue-append ((queue queue) object) + (queue-append queue (list object))) + +(defmethod queue-pop ((queue queue)) + (prog1 (car (queue-first queue)) + (setf (queue-first queue) (cdr (queue-first queue))))) + +(defmethod queue-empty-p ((queue queue)) + (null (queue-first queue))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun package-locked-p (package) + #+sbcl (sb-ext:package-locked-p package) + #+cmu (ext:package-definition-lock package) + #+clisp (ext:package-lock package) + #-(or sbcl cmu clisp) (error "Don't know how to check whether a package might be locked.")) + +(defun forget-documentation (packages) + "Remove documentation from all known symbols in PACKAGES. If +PACKAGES is NIL remove documentations from all packages. This may not +make sense if your Lisp image has been built so that existing objects +don't get garbage collected. It may work for your own code, though. +Locked packages are left alone. If you need to do those too, unlock +them first." + (flet ((forget (symbol) + (dolist (type '(compiler-macro function method-combination setf structure type variable)) + (when (ignore-errors (documentation symbol type)) + (setf (documentation symbol type) nil))))) + (setf packages (mapcar #'(lambda (pkg) + (if (packagep pkg) + (package-name pkg) + (package-name (find-package pkg)))) + packages)) + (setf packages + ;; don't try to modify locked packages + (remove-if #'package-locked-p + (mapcar #'find-package + (or packages + (list-all-packages))))) + (dolist (package packages) + (with-package-iterator (next package :internal :external) + (loop + (multiple-value-bind (more? symbol) (next) + (unless more? + (return)) + (forget symbol))))) + #+(OR) (do-all-symbols (symbol) + (when (member (symbol-package symbol) packages) + (forget symbol)))) + (values)) + +(defun load-compiled (pathname &optional compiled-pathname) + "Make sure to compile PATHNAME before loading it. Don't compile if +the compiled version is more recent than its source." + ;; be tolerant if we didn't get a type + (unless (probe-file pathname) + (setf pathname (merge-pathnames pathname (make-pathname :type "lisp")))) + (if (probe-file pathname) + (progn + (setf compiled-pathname (or compiled-pathname + (compile-file-pathname pathname))) + (when (or (not (probe-file compiled-pathname)) + (< (file-write-date compiled-pathname) + (file-write-date pathname))) + (compile-file pathname)) + (load compiled-pathname)) + (error "Can't load ~A as it doesn't exist." pathname))) + +;; Just a silly mnemonic for those used to lesser languages +(defmacro swap (x y) + "Swap values of places X and Y." + `(rotatef ,x ,y)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro show (&rest things) + "Debugging macro to show the name and content of variables. You can +also specify forms, not just variables." + (let ((*print-pretty* nil)) + `(let ((*print-circle* t)) + (format t ,(format nil "~~&~{~A=~~:W~~%~}" things) + ,@things) + (finish-output) + (values)))) + +(defmacro memoize-function (name &key test) + "Make function NAME memoized. TEST is passed to MAKE-HASH-TABLE." + `(setf (get ',name 'results-hash-table) + (make-hash-table ,@(when test (list :test test))))) + +(defmacro defun-memoized (name args &body forms) + "Define function NAME and make it memoizable. Then the MEMOIZED +macro can be used to call this function and memoize its results. The +function NAME must accept only one argument and return just one +argument; more complicated cases are not considered. The hash table +test function is the default 'EQL." + `(eval-when (:load-toplevel :compile-toplevel) + (defun ,name ,args ,@forms) + (memoize-function ,name))) + +(defmacro memoized (function arg) + "If necessary call FUNCTION passing ARG so that its return value is +memoized. The next time this form is executed with the same argument +value, the memoized result is returned instead of executing FUNCTION." + (with-gensyms (table key result not-found) + `(be* ,key ,arg + ,table (get ',function 'results-hash-table) + ,not-found (list nil) + ,result (gethash ,key ,table ,not-found) + (if (eq ,not-found ,result) + (setf (gethash ,key ,table) + (,function ,key)) + ,result)))) + + +(defmacro save-file-excursion ((stream &optional position) &body forms) + "Execute FORMS returning, on exit, STREAM to the position it was +before FORMS. Optionally POSITION can be set to the starting offset." + (unless position + (setf position (gensym))) + `(be ,position (file-position ,stream) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(defun circular-list (&rest elements) + "Return a circular list of ELEMENTS." + (setf (cdr (last elements)) elements)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun getenv (var) + "Return the string associate to VAR in the system environment." + #+cmu (cdr (assoc (if (symbolp var) + var + (intern var :keyword)) + ext:*environment-list*)) + #+sbcl (sb-ext:posix-getenv (string var)) + #+lispworks (hcl:getenv var) + #+clisp (ext:getenv (string var)) + #-(or cmu sbcl lispworks clisp) + (error "GETENV not implemented for your Lisp system.")) + +#+clisp (ffi:def-call-out %setenv + (:name "setenv") + (:arguments (name ffi:c-string) (value ffi:c-string) (overwrite ffi:int)) + (:return-type ffi:int) + (:library "libc.so")) + +#+clisp (ffi:def-call-out %unsetenv + (:name "unsetenv") + (:arguments (name ffi:c-string)) + (:return-type ffi:int) + (:library "libc.so")) + +(defun setenv (name value &optional (overwrite t)) + (typecase value + (string) + (pathname + (setf value (native-namestring value))) + (t + (setf value (format nil "~A" value)))) + #+sbcl (unless (zerop (sb-posix:setenv name value (if overwrite 1 0))) + (error "unable to setenv ~A: errno=~A." name + (sb-alien:get-errno))) + #+cmu (be key (keywordify name) + (aif (assoc key + ext:*environment-list*) + (when overwrite + (setf (cdr it) value)) + (setf ext:*environment-list* + (cons (cons key value) + ext:*environment-list*)))) + #-(or cmu sbcl) (unless (zerop (%setenv name value (if overwrite 1 0))) + (error "unable to setenv ~A." name))) + +(defun unsetenv (name) + #+sbcl (unless (zerop (sb-posix:unsetenv name)) + (error "unable to unsetenv ~A: errno=~A." name + (sb-alien:get-errno))) + #+cmu (be key (keywordify name) + (setf ext:*environment-list* + (delete-if #'(lambda (e) + (eq (car e) key)) + ext:*environment-list*))) + #-(or cmu sbcl) (unless (zerop (%unsetenv name)) + (error "unable to unsetenv ~A." name))) + +(defun (setf getenv) (value name) + (if value + (setenv name value t) + (unsetenv name))) + +;; in CMUCL it's much easier (see below) +#-cmu +(defmacro with-system-environment ((&rest var-and-values) &body body) + (be gensym-alist (mapcar #'(lambda (vv) + (list (gensym) (string (car vv)) (cadr vv))) + var-and-values) + `(let ,(mapcar #'(lambda (vv) + (destructuring-bind (varsym var value) vv + (declare (ignore value)) + `(,varsym (getenv ,var)))) + gensym-alist) + (unwind-protect + (progn + ,@(mapcar #'(lambda (vv) + (destructuring-bind (varsym var value) vv + (declare (ignore varsym)) + `(setenv ,var ,value))) + gensym-alist) + ,@body) + ,@(mapcar #'(lambda (vv) + (destructuring-bind (varsym var value) vv + (declare (ignore value)) + `(if ,varsym + (setenv ,var ,varsym) + (unsetenv ,var)))) + gensym-alist))))) + +#+cmu +(defmacro with-system-environment ((&rest var-and-values) &body body) + `(let ((ext:*environment-list* + (append (list ,@(mapcar #'(lambda (vv) + (destructuring-bind (variable value) vv + `(cons ,(keywordify variable) + ,value))) + var-and-values)) + ext:*environment-list*))) + ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun last-member (item list &key key (test #'eq)) + "Return the last sublist in LIST that is prefixed by ITEM." + (loop + with l = list and result = nil + for l2 = (member item l :key key :test test) + while l2 + do (setf result l2 + l (cdr l2)) + finally (return result))) + + +(defun glob->regex (string) + "Convert a shell glob expression into a regular expression string." + (with-output-to-string (out) + ;; globs are always anchored to beginning and end + (write-char #\^ out) + (loop + for i from 0 below (length string) + do (be c (char string i) + (cond ((char= c #\\) + (setf c (char string (incf i)))) + ((find c ".+()|^$") + (write-char #\\ out)) + ((char= c #\*) + (write-char #\. out)) + ((char= c #\?) + (setf c #\.))) + (write-char c out))) + (write-char #\$ out))) diff --git a/third_party/lisp/sclf/serial.lisp b/third_party/lisp/sclf/serial.lisp new file mode 100644 index 0000000000..41d32e4c49 --- /dev/null +++ b/third_party/lisp/sclf/serial.lisp @@ -0,0 +1,62 @@ + ;;; serial.lisp --- serialisation of CLOS objects + + ;;; Copyright (C) 2009 by Walter C. Pelissero + + ;;; Author: Walter C. Pelissero <walter@pelissero.de> + ;;; Project: sclf + +#+cmu (ext:file-comment "$Module: serial.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defclass printable-object-mixin () ()) + +(defmacro reconstruct-object (class &rest args) + `(apply #'make-instance ',class ',args)) + +(defun print-readable-instance (object &optional stream) + (unless stream + (setf stream *standard-output*)) + (be class (class-of object) + (pprint-logical-block (stream (copy-list (class-slots class)) :prefix "#.(" :suffix ")") + (flet ((spc () + (write-char #\space stream))) + (write 'reconstruct-object :stream stream) + (spc) + (write (class-name class) :stream stream :escape t :readably t :pretty t) + (pprint-exit-if-list-exhausted) + (spc) + (loop + (be* slot (pprint-pop) + slot-name (slot-definition-name slot) + initarg (car (slot-definition-initargs slot)) + (when (and initarg + (slot-boundp object slot-name)) + (write initarg :stream stream) + (spc) + (when *print-pretty* + (pprint-newline :miser stream)) + (write (slot-value object slot-name) + :stream stream) + (pprint-exit-if-list-exhausted) + (if *print-pretty* + (pprint-newline :linear stream) + (spc))))))))) + +(defmethod print-object ((object printable-object-mixin) stream) + (if *print-readably* + (print-readable-instance object stream) + (call-next-method))) diff --git a/third_party/lisp/sclf/sysproc.lisp b/third_party/lisp/sclf/sysproc.lisp new file mode 100644 index 0000000000..1dd559ebe3 --- /dev/null +++ b/third_party/lisp/sclf/sysproc.lisp @@ -0,0 +1,295 @@ +;;; sysproc.lisp --- system processes + +;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: sysproc.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defvar *bourne-shell* "/bin/sh") + +(defvar *run-verbose* nil + "If true system commands are displayed before execution and standard +error is not discarded.") + +;; +;; SIGINFO is missing in both CMUCL and SBCL +;; + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant unix::siginfo 29) + (defvar siginfo (unix::make-unix-signal :siginfo unix::siginfo "Information")) + (export '(unix::siginfo) "UNIX") + (pushnew siginfo unix::*unix-signals*)) + +#+sbcl (in-package :sb-posix) +#+sbcl +(eval-when (:execute :compile-toplevel :load-toplevel) + (unless (find-symbol "SIGINFO" :sb-posix) + (sb-ext:with-unlocked-packages (:sb-posix) + (defvar siginfo 29) + (export '(SIGINFO))))) +#+sbcl (in-package :sclf) + +(defun signal-number (signal-name) + (ecase signal-name + ((:abrt :abort) + #+cmu unix:sigabrt + #+sbcl sb-posix:sigabrt) + ((:alrm :alarm) + #+cmu unix:sigalrm + #+sbcl sb-posix:sigalrm) + ((:bus :bus-error) + #+cmu unix:sigbus + #+sbcl sb-posix:sigbus) + ((:chld :child) + #+cmu unix:sigchld + #+sbcl sb-posix:sigchld) + ((:cont :continue) + #+cmu unix:sigcont + #+sbcl sb-posix:sigcont) + #+freebsd((:emt :emulate-instruction) + #+cmu unix:sigemt + #+sbcl sb-posix:sigemt) + ((:fpe :floating-point-exception) + #+cmu unix:sigfpe + #+sbcl sb-posix:sigfpe) + ((:hup :hangup) + #+cmu unix:sighup + #+sbcl sb-posix:sighup) + ((:ill :illegal :illegal-instruction) + #+cmu unix:sigill + #+sbcl sb-posix:sigill) + ((:int :interrupt) + #+cmu unix:sigint + #+sbcl sb-posix:sigint) + ((:io :input-output) + #+cmu unix:sigio + #+sbcl sb-posix:sigio) + (:kill + #+cmu unix:sigkill + #+sbcl sb-posix:sigkill) + ((:pipe :broke-pipe) + #+cmu unix:sigpipe + #+sbcl sb-posix:sigpipe) + ((:prof :profiler) + #+cmu unix:sigprof + #+sbcl sb-posix:sigprof) + (:quit + #+cmu unix:sigquit + #+sbcl sb-posix:sigquit) + ((:segv :segmentation-violation) + #+cmu unix:sigsegv + #+sbcl sb-posix:sigsegv) + (:stop + #+cmu unix:sigstop + #+sbcl sb-posix:sigstop) + ((:sys :system-call) + #+cmu unix:sigsys + #+sbcl sb-posix:sigsys) + ((:term :terminate) + #+cmu unix:sigterm + #+sbcl sb-posix:sigterm) + ((:trap) + #+cmu unix:sigtrap + #+sbcl sb-posix:sigtrap) + ((:tstp :terminal-stop) + #+cmu unix:sigtstp + #+sbcl sb-posix:sigtstp) + ((:ttin :tty-input) + #+cmu unix:sigttin + #+sbcl sb-posix:sigttin) + ((:ttou :tty-output) + #+cmu unix:sigttou + #+sbcl sb-posix:sigttou) + ((:urg :urgent) + #+cmu unix:sigurg + #+sbcl sb-posix:sigurg) + ((:usr1 :user1) + #+cmu unix:sigusr1 + #+sbcl sb-posix:sigusr1) + ((:usr2 :user2) + #+cmu unix:sigusr2 + #+sbcl sb-posix:sigusr2) + ((:vtalrm :virtual-timer-alarm) + #+cmu unix:sigvtalrm + #+sbcl sb-posix:sigvtalrm) + ((:winch :window-change :window-size-change) + #+cmu unix:sigwinch + #+sbcl sb-posix:sigwinch) + ((:xcpu :exceeded-cpu) + #+cmu unix:sigxcpu + #+sbcl sb-posix:sigxcpu) + ((:xfsz :exceeded-file-size) + #+cmu unix:sigxfsz + #+sbcl sb-posix:sigxfsz) + ;; oddly this is not defined by neither CMUCL nor SBCL + (:info 29))) + +(defun sysproc-kill (process signal) + (when (keywordp signal) + (setf signal (signal-number signal))) + #+cmu (ext:process-kill process signal) + #+sbcl (sb-ext:process-kill process signal) + #-(or sbcl cmu) (error "Don't know how to kill a process")) + +(defun sysproc-exit-code (process) + #+cmu (ext:process-exit-code process) + #+sbcl (sb-ext:process-exit-code process) + #-(or sbcl cmu) (error "Don't know how to get a process exit code")) + +(defun sysproc-wait (process) + #+cmu (ext:process-wait process) + #+sbcl (sb-ext:process-wait process) + #-(or sbcl cmu) (error "Don't know how to wait a process")) + +(defun sysproc-input (process) + #+cmu (ext:process-input process) + #+sbcl (sb-ext:process-input process) + #-(or sbcl cmu) (error "Don't know how to get the process input")) + +(defun sysproc-output (process) + #+cmu (ext:process-output process) + #+sbcl (sb-ext:process-output process) + #-(or sbcl cmu) (error "Don't know how to get the process output")) + +(defun sysproc-alive-p (process) + #+cmu (ext:process-alive-p process) + #+sbcl (sb-ext:process-alive-p process) + #-(or sbcl cmu) (error "Don't know how to test wether a process might be running")) + +(defun sysproc-pid (process) + #+cmu (ext:process-pid process) + #+sbcl (sb-ext:process-pid process) + #-(or sbcl cmu) (error "Don't know how to get the id of a process")) + +(defun sysproc-p (thing) + #+sbcl (sb-ext:process-p thing) + #+cmu (ext:process-p thing) + #-(or sbcl cmu) (error "Don't know how to figure out whether something is a system process")) + +(defun run-program (program arguments &key (wait t) pty input output error) + "Run PROGRAM with ARGUMENTS (a list) and return a process object." + ;; convert arguments to strings + (setf arguments + (mapcar #'(lambda (item) + (typecase item + (string item) + (pathname (native-namestring item)) + (t (format nil "~A" item)))) + arguments)) + (when *run-verbose* + (unless error + (setf error t)) + (format t "~&; run-pipe ~A~{ ~S~}~%" program arguments)) + #+cmu (ext:run-program program arguments + :wait wait + :pty pty + :input input + :output output + :error (or error *run-verbose*)) + #+sbcl (sb-ext:run-program program arguments + :search t + :wait wait + :pty pty + :input input + :output output + :error (or error *run-verbose*)) + #-(or sbcl cmu) + (error "Unsupported Lisp system.")) + +(defun run-pipe (direction program arguments &key error) + "Run PROGRAM with a list of ARGUMENTS and according to DIRECTION +return the input and output streams and process object of that +process." + (be process (run-program program arguments + :wait nil + :pty nil + :input (when (member direction '(:output :input-output :io)) + :stream) + :output (when (member direction '(:input :input-output :io)) + :stream) + :error error) + (values (sysproc-output process) + (sysproc-input process) + process)) + #-(or sbcl cmu) + (error "Unsupported Lisp system.")) + +(defun exit-code (process) + (sysproc-wait process) + (sysproc-exit-code process)) + +(defun run-shell-command (fmt &rest args) + "Run a Bourne Shell command. Return the exit status of the command." + (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args)))) + +(defun run-async-shell-command (fmt &rest args) + "Run a Bourne Shell command asynchronously. Return a process +object if provided by your Lisp implementation." + (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args)) + :wait nil)) + +(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms) + "Run BODY with IN and OUT bound respectively to an input and an +output stream connected to a system process created by running PROGRAM +with ARGUMENTS. If IN or OUT are NIL, then don't create that stream." + (with-gensyms (prg args) + `(be* ,prg ,program + ,args ,arguments + ,process (run-program ,prg ,args + :output ,(case in + ((t nil) in) + (t :stream)) + :input ,(case out + ((t nil) out) + (t :stream)) + :wait nil + :pty ,pty + ,@(when error `(:error ,error))) + (if ,process + (let (,@(case in + ((t nil)) + (t `((,in (sysproc-output ,process))))) + ,@(case out + ((t nil)) + (t `((,out (sysproc-input ,process)))))) + (unwind-protect + (progn + ,@forms) + ,@(case in + ((t nil)) + (t `((close ,in)))) + ,@(case out + ((t nil)) + (t `((close ,out)))) + (when (sysproc-alive-p ,process) + (sysproc-kill ,process :term)))) + (error "unable to run ~A~{ ~A~}." ,prg ,args))))) + + +(defun sysproc-set-signal-callback (signal handler) + "Arrange HANDLER function to be called when receiving the system +signal SIGNAL." + (when (keywordp signal) + (setf signal (signal-number signal))) + #+cmu (system:enable-interrupt signal handler) + #+sbcl (sb-sys:enable-interrupt signal handler) + #-(or cmu sbcl) (error "Don't know how to set a system signal callback.")) diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp new file mode 100644 index 0000000000..71b943aa43 --- /dev/null +++ b/third_party/lisp/sclf/time.lisp @@ -0,0 +1,311 @@ +;;; time.lisp --- time primitives + +;;; Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: sclf + +#+cmu (ext:file-comment "$Module: time.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :sclf) + +(defun year (epoch &optional time-zone) + "Return the year of EPOCH." + (sixth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun month (epoch &optional time-zone) + "Return the month of EPOCH." + (fifth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun day (epoch &optional time-zone) + "Return the day of EPOCH." + (fourth (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun week-day (epoch &optional time-zone) + "Return the day of the week of EPOCH." + (seventh (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun hour (epoch &optional time-zone) + "Return the hour of EPOCH." + (third (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun minute (epoch &optional time-zone) + "Return the minute of EPOCH." + (second (multiple-value-list (decode-universal-time epoch time-zone)))) + +(defun leap-year-p (year) + "Return true if YEAR is a leap year." + (and (zerop (mod year 4)) + (or (not (zerop (mod year 100))) + (zerop (mod year 400))))) + +(defun last-day-of-month (month year) + "Return the last day of the month as integer." + (be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)) + (if (and (= last 28) + (leap-year-p year)) + (1+ last) + last))) + +(defun add-months (months epoch &optional time-zone) + "Add MONTHS to EPOCH, which is a universal time. MONTHS can be +negative." + (multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone) + (multiple-value-bind (y m) (floor (+ month months -1) 12) + (let ((new-month (1+ m)) + (new-year (+ year y))) + (encode-universal-time ss mm hh + (min day (last-day-of-month new-month (year epoch))) + new-month + new-year + time-zone))))) + +(defun add-days (days epoch) + "Add DAYS to EPOCH, which is an universal time. DAYS can be +negative." + (+ (* 60 60 24 days) epoch)) + +;; The following two functions are based on Thomas Russ <tar@isi.edu> +;; code which didn't carry any copyright notice, so I assume it was in +;; the public domain. + +(defun iso-time-string (time &key time-zone with-timezone-p basic) + "Return an ISO 8601 string representing TIME. The time zone is +included if WITH-TIMEZONE-P is true." + (flet ((format-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Sign of time zone is reversed in ISO 8601 relative + ;; to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round m)))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time time-zone) + (declare (ignore dow dst)) + (if basic + (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)))))) + +(defun parse-iso-time-string (time-string) + "Parse an ISO 8601 formated string and return the universal time. +It can parse the basic and the extended format, but may not be able to +cover all the cases." + (labels ((parse-delimited-string (string delimiter n) + ;; Parses a delimited string and returns a list of + ;; n integers found in that string. + (let ((answer (make-list n :initial-element 0))) + (loop + for i upfrom 0 + for start = 0 then (1+ end) + for end = (position delimiter string :start (1+ start)) + do (setf (nth i answer) + (parse-integer (subseq string start end))) + when (null end) return t) + (values-list answer))) + (parse-fixed-field-string (string field-sizes) + ;; Parses a string with fixed length fields and returns + ;; a list of integers found in that string. + (let ((answer (make-list (length field-sizes) :initial-element 0))) + (loop + with len = (length string) + for start = 0 then (+ start field-size) + for field-size in field-sizes + for i upfrom 0 + while (< start len) + do (setf (nth i answer) + (parse-integer (subseq string start (+ start field-size))))) + (values-list answer))) + (parse-iso8601-date (date-string) + (let ((hyphen-pos (position #\- date-string))) + (if hyphen-pos + (parse-delimited-string date-string #\- 3) + (parse-fixed-field-string date-string '(4 2 2))))) + (parse-iso8601-timeonly (time-string) + (let* ((colon-pos (position #\: time-string)) + (zone-pos (or (position #\- time-string) + (position #\+ time-string))) + (timeonly-string (subseq time-string 0 zone-pos)) + (zone-string (when zone-pos (subseq time-string (1+ zone-pos)))) + (time-zone nil)) + (when zone-pos + (multiple-value-bind (zone-h zone-m) + (parse-delimited-string zone-string #\: 2) + (setq time-zone (+ zone-h (/ zone-m 60))) + (when (char= (char time-string zone-pos) #\-) + (setq time-zone (- time-zone))))) + (multiple-value-bind (hh mm ss) + (if colon-pos + (parse-delimited-string timeonly-string #\: 3) + (parse-fixed-field-string timeonly-string '(2 2 2))) + (values hh mm ss time-zone))))) + (let ((time-separator (position #\T time-string))) + (multiple-value-bind (year month date) + (parse-iso8601-date + (subseq time-string 0 time-separator)) + (if time-separator + (multiple-value-bind (hh mm ss zone) + (parse-iso8601-timeonly + (subseq time-string (1+ time-separator))) + (if zone + ;; Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (encode-universal-time ss mm hh date month year (- zone)) + (encode-universal-time ss mm hh date month year))) + (encode-universal-time 0 0 0 date month year)))))) + +(defun time-string (time &optional time-zone) + "Return a string representing TIME in the form: + Tue Jan 25 12:55:40 2005" + (multiple-value-bind (ss mm hh day month year week-day) + (decode-universal-time time time-zone) + (format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A" + (subseq (week-day->string week-day) 0 3) + (subseq (month->string month) 0 3) + day + hh mm ss + year))) + +(defun beginning-of-month (month year &optional time-zone) + (encode-universal-time 0 0 0 1 month year time-zone)) + +(defun end-of-month (month year &optional time-zone) + (1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone)))) + +(defun beginning-of-first-week (year &optional time-zone) + "Return the epoch of the first week of YEAR. As the first week +of the year needs to have Thursday in this YEAR, the returned +time can actually fall in the previous year." + (let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone)) + (start (- 4 (week-day (add-days 4 Jan-1st))))) + (add-days start Jan-1st))) + +(defun beginning-of-week (week year &optional time-zone) + "Return the epoch of the beginning of WEEK of YEAR." + (add-days (* (1- week) 7) (beginning-of-first-week year time-zone))) + +(defun end-of-week (week year &optional time-zone) + "Return the epoch of the beginning of WEEK of YEAR." + (1- (beginning-of-week (1+ week) year time-zone))) + +(defun end-of-last-week (year &optional time-zone) + "Return the epoch of the last week of YEAR. As the last week +of the year needs to have Thursday in this YEAR, the returned +time can fall in the next year." + (1- (beginning-of-first-week (1+ year) time-zone))) + +(defun seconds-from-beginning-of-the-year (time &optional time-zone) + (- time (encode-universal-time 0 0 0 1 1 (year time) time-zone))) + +(defun day-of-the-year (time &optional time-zone) + "Return the day within the year of TIME starting from 1 up to +365 (or 366)." + (1+ (truncate (seconds-from-beginning-of-the-year time time-zone) + (* 60 60 24)))) + +(defun week (time &optional time-zone) + "Return the number of the week and the year TIME referes to. +Week is an integer from 1 to 52. Due to the way the first week +of the year is calculated a day in one year could actually be in +the last week of the previous or next year." + (let* ((year (year time)) + (start (beginning-of-first-week year time-zone)) + (days-from-start (truncate (- time start) (* 60 60 24))) + (weeks (truncate days-from-start 7)) + (week-number (mod weeks 52))) + (values (1+ week-number) + (cond ((< weeks 0) + (1- year)) + ((> weeks 51) + (1+ year)) + (t year))))) + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) + +(defun month-string->number (month) + (1+ (position month +month-names+ :test #'string-equal))) + +(defun print-time-span (span &optional stream) + "Print in English the time SPAN expressed in seconds." + (let* ((minute 60) + (hour (* minute 60)) + (day (* hour 24)) + (seconds span)) + (macrolet ((split (divisor) + `(when (>= seconds ,divisor) + (prog1 (truncate seconds ,divisor) + (setf seconds (mod seconds ,divisor)))))) + (let* ((days (split day)) + (hours (split hour)) + (minutes (split minute))) + (format stream "~{~A~^ ~}" (remove nil + (list + (when days + (format nil "~D day~:P" days)) + (when hours + (format nil "~D hour~:P" hours)) + (when minutes + (format nil "~D minute~:P" minutes)) + (when (or (> seconds 0) + (= span 0)) + (format nil "~D second~:P" seconds))))))))) + +(defun next-week-day (epoch week-day &optional time-zone) + "Return the universal time of the next WEEK-DAY starting from epoch." + (add-days (mod (- week-day (week-day epoch time-zone)) 7) + epoch)) + +(defun next-monday (epoch &optional time-zone) + "Return the universal time of the next Monday starting from +EPOCH." + (next-week-day epoch 0 time-zone)) + +(defun full-weeks-in-span (start end &optional time-zone) + "Return the number of full weeks in time span START to END. A +full week starts on Monday and ends on Sunday." + (be first-monday (next-monday start time-zone) + (truncate (- end first-monday) (* 7 24 60 60)))) + +(defconst +unix-lisp-time-difference+ + (encode-universal-time 0 0 0 1 1 1970 0) + "Time difference between Unix epoch and Common Lisp epoch. The +former is 1st January 1970, while the latter is the beginning of the +XX century.") + +(defun universal->unix-time (time) + (- time +unix-lisp-time-difference+)) + +(defun unix->universal-time (time) + (+ time +unix-lisp-time-difference+)) + +(defun get-unix-time () + (universal->unix-time (get-universal-time))) diff --git a/third_party/lisp/split-sequence.nix b/third_party/lisp/split-sequence.nix new file mode 100644 index 0000000000..4e8f723c31 --- /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 0000000000..27949e8be1 --- /dev/null +++ b/third_party/lisp/trivial-backtrace.nix @@ -0,0 +1,15 @@ +# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-backtrace; +in depot.nix.buildLisp.library { + name = "trivial-backtrace"; + + srcs = map (f: src + ("/dev/" + f)) [ + "packages.lisp" + "utilities.lisp" + "backtrace.lisp" + "map-backtrace.lisp" + "fallback.lisp" + ]; +} diff --git a/third_party/lisp/trivial-features.nix b/third_party/lisp/trivial-features.nix new file mode 100644 index 0000000000..02abac54a8 --- /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 0000000000..74224df60d --- /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 0000000000..62a30f1e94 --- /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 0000000000..70a6e19d48 --- /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 0000000000..c85fe2accb --- /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 0000000000..b097a3d0ee --- /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 0000000000..f98c029d36 --- /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 0000000000..2482961132 --- /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 0000000000..5d6d04535f --- /dev/null +++ b/third_party/lisp/usocket-server.nix @@ -0,0 +1,19 @@ +# Universal socket library for Common Lisp (server side) +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.usocket-server; +in +buildLisp.library { + name = "usocket-server"; + + deps = with depot.third_party.lisp; [ + usocket + bordeaux-threads + ]; + + srcs = [ + "${src}/server.lisp" + ]; +} diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix new file mode 100644 index 0000000000..589a3a0cfc --- /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"; } + ]); +} |