diff options
Diffstat (limited to 'third_party/lisp')
40 files changed, 955 insertions, 4139 deletions
diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS index 2d7f7e237b..6536baf505 100644 --- a/third_party/lisp/OWNERS +++ b/third_party/lisp/OWNERS @@ -1,5 +1,2 @@ -# -*- mode: yaml; -*- -inherited: true -owners: - - eta - - grfn +eta +aspen diff --git a/third_party/lisp/cl-change-case.nix b/third_party/lisp/cl-change-case.nix new file mode 100644 index 0000000000..b66368a9b6 --- /dev/null +++ b/third_party/lisp/cl-change-case.nix @@ -0,0 +1,22 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-change-case; +in depot.nix.buildLisp.library { + name = "cl-change-case"; + + deps = with depot.third_party.lisp; [ cl-ppcre cl-ppcre.unicode ]; + + srcs = [ (src + "/src/cl-change-case.lisp") ]; + + tests = { + name = "cl-change-case-tests"; + srcs = [ (src + "/t/cl-change-case.lisp") ]; + deps = [ + depot.third_party.lisp.fiveam + ]; + + expression = '' + (5am:run! :cl-change-case) + ''; + }; +} diff --git a/third_party/lisp/cl-json.nix b/third_party/lisp/cl-json.nix index 0230f274af..6b82fac772 100644 --- a/third_party/lisp/cl-json.nix +++ b/third_party/lisp/cl-json.nix @@ -4,19 +4,22 @@ let inherit (depot.nix) buildLisp; + # https://github.com/sharplispers/cl-json/pull/12/ src = pkgs.fetchFromGitHub { - owner = "hankhero"; + owner = "sternenseemann"; repo = "cl-json"; - rev = "6dfebb9540bfc3cc33582d0c03c9ec27cb913e79"; - sha256 = "0fx3m3x3s5ji950yzpazz4s0img3l6b3d6l3jrfjv0lr702496lh"; + rev = "c059bec94e28a11102a994d6949e2e52764f21fd"; + sha256 = "0l07syw1b1x2zi8kj4iph3rf6vi6c16b7fk69iv7x27wrdsr1qwj"; }; + + getSrcs = subdir: map (f: src + ("/" + subdir + "/" + f)); in buildLisp.library { name = "cl-json"; deps = [ (buildLisp.bundled "asdf") ]; srcs = [ "${src}/cl-json.asd" ] ++ - (map (f: src + ("/src/" + f)) [ + (getSrcs "src" [ "package.lisp" "common.lisp" "objects.lisp" @@ -26,4 +29,25 @@ buildLisp.library { "utils.lisp" "json-rpc.lisp" ]); + + tests = { + deps = [ + depot.third_party.lisp.cl-unicode + depot.third_party.lisp.fiveam + ]; + srcs = [ + # CLOS tests are broken upstream as well + # https://github.com/sharplispers/cl-json/issues/11 + (pkgs.writeText "no-clos-tests.lisp" '' + (replace *features* (delete :cl-json-clos *features*)) + '') + ] ++ getSrcs "t" [ + "package.lisp" + "testencoder.lisp" + "testdecoder.lisp" + "testmisc.lisp" + ]; + + expression = "(fiveam:run! 'json-test::json)"; + }; } diff --git a/third_party/lisp/cl-ppcre.nix b/third_party/lisp/cl-ppcre.nix index 561e306191..7cb99db639 100644 --- a/third_party/lisp/cl-ppcre.nix +++ b/third_party/lisp/cl-ppcre.nix @@ -24,4 +24,16 @@ in depot.nix.buildLisp.library { "scanner.lisp" "api.lisp" ]; + + passthru = { + unicode = depot.nix.buildLisp.library { + name = "cl-ppcre-unicode"; + deps = with depot.third_party.lisp; [ cl-ppcre cl-unicode ]; + + srcs = map (f: src + ("/cl-ppcre-unicode/" + f)) [ + "packages.lisp" + "resolver.lisp" + ]; + }; + }; } diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix index 8deba4546f..296112cc9e 100644 --- a/third_party/lisp/lisp-binary.nix +++ b/third_party/lisp/lisp-binary.nix @@ -2,22 +2,18 @@ { depot, pkgs, ... }: let - src = pkgs.fetchFromGitHub { - owner = "j3pic"; - repo = "lisp-binary"; - rev = "052df578900dea59bf951e0a6749281fa73432e4"; - sha256 = "1i1s5g01aimfq6lndcl1pnw7ly5hdh0wmjp2dj9cjjwbkz9lnwcf"; - }; + src = pkgs.srcOnly pkgs.lispPackages.lisp-binary; in depot.nix.buildLisp.library { name = "lisp-binary"; deps = with depot.third_party.lisp; [ + alexandria cffi - quasiquote_2 - moptilities - flexi-streams closer-mop + flexi-streams + moptilities + quasiquote_2 ]; srcs = map (f: src + ("/" + f)) [ @@ -32,6 +28,6 @@ depot.nix.buildLisp.library { ]; brokenOn = [ - "ecl" # dynamic cffi + "ecl" # TODO(sterni): disable conditionally cffi for ECL ]; } diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS index f16dd105d7..2e95807063 100644 --- a/third_party/lisp/mime4cl/OWNERS +++ b/third_party/lisp/mime4cl/OWNERS @@ -1,3 +1 @@ -inherited: true -owners: - - sterni +sterni diff --git a/third_party/lisp/mime4cl/README b/third_party/lisp/mime4cl/README deleted file mode 100644 index 73f0efbda9..0000000000 --- a/third_party/lisp/mime4cl/README +++ /dev/null @@ -1,7 +0,0 @@ -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/README.md b/third_party/lisp/mime4cl/README.md new file mode 100644 index 0000000000..2704d481ed --- /dev/null +++ b/third_party/lisp/mime4cl/README.md @@ -0,0 +1,27 @@ +# mime4cl + +`MIME4CL` is a Common Lisp library for dealing with MIME messages. It was +originally been written by Walter C. Pelissero and vendored into depot +([mime4cl-20150207T211851.tbz](http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz) +to be exact) as upstream has become inactive. Its [original +website](http://wcp.sdf-eu.org/software/#mime4cl) can still be accessed. + +The depot version has since diverged from upstream. Main aims were to improve +performance and reduce code size by relying on third party libraries like +flexi-streams. It is planned to improve encoding handling in the long term. +Currently, the library is being worked on intermittently and not very well +tested—**it may not work as expected**. + +## Differences from the original version + +* `//nix/buildLisp` is used as the build system. ASDF is currently untested and + may be broken. + +* The dependency on [sclf](http://wcp.sdf-eu.org/software/#sclf) has been + eliminated by inlining the relevant parts. + +* `MY-STRING-INPUT-STREAM`, `DELIMITED-INPUT-STREAM`, + `CHARACTER-INPUT-ADAPTER-STREAM`, `BINARY-INPUT-ADAPTER-STREAM` etc. have been + replaced by (thin wrappers around) flexi-streams. In addition to improved + handling of encodings, this allows using `READ-SEQUENCE` via the gray stream + interface. diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp index 944156916c..42688a595b 100644 --- a/third_party/lisp/mime4cl/address.lisp +++ b/third_party/lisp/mime4cl/address.lisp @@ -1,7 +1,7 @@ ;;; address.lisp --- e-mail address parser ;;; Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero -;;; Copyright (C) 2022 The TVL Authors +;;; Copyright (C) 2022-2023 The TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -219,14 +219,14 @@ (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))))) + (let ((string (with-output-to-string (out) + (write-char first-character out) + (loop + for c = (read-char (cursor-stream cursor) nil) + while (and c (atom-component-p c)) + do (write-char c out) + finally (when c + (unread-char c (cursor-stream cursor))))))) (make-token :type 'atext :value string :position (incf (cursor-position cursor))))) @@ -236,7 +236,7 @@ (make-token :type 'keyword :value (string c) :position (incf (cursor-position cursor))))) - (be in (cursor-stream cursor) + (let ((in (cursor-stream cursor))) (loop for c = (read-char in nil) while c @@ -259,7 +259,7 @@ "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) + (let ((cursor (make-cursor :stream stream))) (loop for tokens = (read-next-tokens cursor) until (endp tokens) @@ -282,19 +282,19 @@ addresses only." 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) + (let ((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)) + (let* ((cursor (make-cursor :stream stream)) + (mailboxes (ignore-errors ; ignore parsing errors + (parse grammar 'address-list cursor)))) (if no-groups (mailboxes-only mailboxes) mailboxes))))) (defun debug-addresses (string) "More or less like PARSE-ADDRESSES, but don't ignore parsing errors." - (be grammar (force define-grammar) + (let ((grammar (force define-grammar))) (with-input-from-string (stream string) - (be cursor (make-cursor :stream stream) + (let ((cursor (make-cursor :stream stream))) (parse grammar 'address-list cursor))))) diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix index 9d3d6253f4..af015a257b 100644 --- a/third_party/lisp/mime4cl/default.nix +++ b/third_party/lisp/mime4cl/default.nix @@ -6,13 +6,15 @@ depot.nix.buildLisp.library { name = "mime4cl"; deps = [ - depot.third_party.lisp.babel - depot.third_party.lisp.sclf + depot.third_party.lisp.flexi-streams depot.third_party.lisp.npg depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.qbase64 + { sbcl = depot.nix.buildLisp.bundled "sb-posix"; } ]; srcs = [ + ./ex-sclf.lisp ./package.lisp ./endec.lisp ./streams.lisp @@ -29,11 +31,10 @@ depot.nix.buildLisp.library { (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}")) + ;; override auto discovery which doesn't work in the nix store + (defvar *samples-directory* (pathname "${./test/samples}/")) '') + ./test/temp-file.lisp ./test/endec.lisp ./test/address.lisp ./test/mime.lisp diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp index 020c212e5e..2e282c2378 100644 --- a/third_party/lisp/mime4cl/endec.lisp +++ b/third_party/lisp/mime4cl/endec.lisp @@ -1,6 +1,7 @@ ;;; endec.lisp --- encoder/decoder functions ;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2023 by The TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -21,19 +22,21 @@ (in-package :mime4cl) +(defun redirect-stream (in out &key (buffer-size 4096)) + "Consume input stream IN and write all its content to output stream OUT. +The streams' element types need to match." + (let ((buf (make-array buffer-size :element-type (stream-element-type in)))) + (loop for pos = (read-sequence buf in) + while (> pos 0) + do (write-sequence buf out :end pos)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Thank you SBCL for rendering constants totally useless! (defparameter +base64-encode-table+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") -(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+)) +(declaim (type simple-string +base64-encode-table+)) (defvar *base64-line-length* 76 "Maximum length of the encoded base64 line. NIL means it can @@ -161,7 +164,7 @@ It should expect a character as its only argument.")) for byte = (decoder-read-byte decoder) unless byte do (return-from decoder-read-line nil) - do (be c (code-char byte) + do (let ((c (code-char byte))) (cond ((char= c #\return) ;; skip the newline (decoder-read-byte decoder) @@ -198,7 +201,7 @@ value." (save (c) (saveb (char-code c))) (push-next () - (be c (funcall input-function) + (let ((c (funcall input-function))) (declare (type (or null character) c)) (cond ((not c)) ((or (char= c #\space) @@ -206,7 +209,7 @@ value." (save c) (push-next)) ((char= c #\=) - (be c1 (funcall input-function) + (let ((c1 (funcall input-function))) (cond ((not c1) (save #\=)) ((char= c1 #\return) @@ -221,7 +224,7 @@ value." (push-next)) (t ;; hexadecimal sequence: get the 2nd digit - (be c2 (funcall input-function) + (let ((c2 (funcall input-function))) (if c2 (aif (parse-hex c1 c2) (saveb it) @@ -271,10 +274,10 @@ binary output OUT the decoded stream of bytes." (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) + `(let ((,output-sequence (make-array 0 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t))) (make-decoder-loop ,decoder-class ,input-form (vector-push-extend byte ,output-sequence) :parser-errors ,parser-errors) @@ -377,7 +380,7 @@ characters quoted printables encoded." (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 + (let ((i start)) (make-encoder-loop quoted-printable-encoder (when (< i end) (prog1 (elt sequence i) @@ -470,7 +473,7 @@ character stream." (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 + (let ((i start)) (make-encoder-loop base64-encoder (when (< i end) (prog1 (elt sequence i) @@ -483,60 +486,34 @@ 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)) + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (redirect-stream (make-instance 'qbase64:decode-stream + :underlying-stream in) + out)) (defun decode-base64-stream-to-sequence (stream &key parser-errors) - (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))) + "Read Base64 characters from STREAM and return result of decoding them as a +binary sequence." + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (let* ((buffered-size 4096) + (dstream (make-instance 'qbase64:decode-stream + :underlying-stream stream)) + (output-seq (make-array buffered-size + :element-type '(unsigned-byte 8) + :adjustable t))) + (loop for cap = (array-dimension output-seq 0) + for pos = (read-sequence output-seq dstream :start (or pos 0)) + if (>= pos cap) + do (adjust-array output-seq (+ cap buffered-size)) + else + do (progn + (adjust-array output-seq pos) + (return output-seq))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -547,25 +524,14 @@ to OUT a stream of decoded bytes." 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)) + ;; parser-errors-p is unused in base64 + (qbase64:decode-string string)) (otherwise (map '(vector (unsigned-byte 8)) #'char-code string)))) @@ -649,7 +615,7 @@ method of RFC2047 and return a sequence of bytes." 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)) + ("B" (qbase64:decode-string (subseq string start end))) (t string))) (defun parse-RFC2047-text (text) @@ -684,13 +650,13 @@ sequence, a charset string indicating the original coding." (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." + encountered, try to decode it using flexi-streams, otherwise signal an error." (flet ((decode-part (part) (etypecase part - (cons (babel:octets-to-string + (cons (flexi-streams:octets-to-string (car part) - :encoding (babel-encodings:get-character-encoding - (intern (string-upcase (cdr part)) 'keyword)))) + :external-format (flexi-streams:make-external-format + (intern (string-upcase (cdr part)) 'keyword)))) (string part)))) (apply #'concatenate (cons 'string diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp new file mode 100644 index 0000000000..1719732fb3 --- /dev/null +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -0,0 +1,329 @@ +;;; ex-sclf.lisp --- subset of sclf used by mime4cl + +;;; Copyright (C) 2005-2010 by Walter C. Pelissero +;;; Copyright (C) 2022-2023 The TVL Authors + +;;; Author: sternenseemann <sternenseemann@systemli.org> +;;; Project: mime4cl +;;; +;;; mime4cl uses sclf for miscellaneous utility functions. sclf's portability +;;; is quite limited. Since mime4cl is the only thing in TVL's depot depending +;;; on sclf, it made more sense to strip down sclf to the extent mime4cl needed +;;; in order to lessen the burden of porting it to other CL implementations +;;; later. +;;; +;;; Eventually it probably makes sense to drop the utilities we don't like and +;;; merge the ones we do like into depot's own utility package, klatre. + +#+cmu (ext:file-comment "$Module: ex-sclf.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :mime4cl-ex-sclf + (:use :common-lisp) + (:import-from :sb-posix :stat :stat-size) + + (:export + #:aif + #:awhen + #:aand + #:it + + #:gcase + + #:with-gensyms + + #:split-at + #:split-string-at-char + #:+whitespace+ + #:whitespace-p + #:string-concat + #:s+ + #:string-starts-with + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + + #:queue + #:make-queue + #:queue-append + #:queue-pop + #:queue-empty-p + + #:save-file-excursion + #:read-file + + #:file-size + + #:promise + #:make-promise + #:lazy + #:force + #:forced-p + #:deflazy + + #:f++ + + #:week-day->string + #:month->string)) + +(in-package :mime4cl-ex-sclf) + +;; MACRO UTILS + +(defmacro with-gensyms ((&rest symbols) &body body) + "Gensym all SYMBOLS and make them available in BODY. +See also LET-GENSYMS." + `(let ,(mapcar #'(lambda (s) + (list s '(gensym))) symbols) + ,@body)) + +;; CONTROL FLOW + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(let ((it ,test)) + (when it + ,@then))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro gcase ((value &optional (test 'equalp)) &rest cases) + "Generic CASE macro. Match VALUE to CASES as if by the normal CASE +but use TEST as the comparison function, which defaults to EQUALP." + (with-gensyms (val) + `(let ((,val ,value)) + ,(cons 'cond + (mapcar #'(lambda (case-desc) + (destructuring-bind (vals &rest forms) case-desc + `(,(cond ((consp vals) + (cons 'or (mapcar #'(lambda (v) + (list test val v)) + vals))) + ((or (eq vals 'otherwise) + (eq vals t)) + t) + (t (list test val vals))) + ,@forms))) + cases))))) + +;; SEQUENCES + +(defun position-any (bag sequence &rest position-args) + "Find any element of bag in sequence and return its position. +Accept any argument accepted by the POSITION function." + (apply #'position-if #'(lambda (element) + (find element bag)) sequence position-args)) + +(defun split-at (bag sequence &key (start 0) key) + "Split SEQUENCE at occurence of any element from BAG. +Contiguous occurences of elements from BAG are considered atomic; +so no empty sequence is returned." + (let ((len (length sequence))) + (labels ((split-from (start) + (unless (>= start len) + (let ((sep (position-any bag sequence :start start :key key))) + (cond ((not sep) + (list (subseq sequence start))) + ((> sep start) + (cons (subseq sequence start sep) + (split-from (1+ sep)))) + (t + (split-from (1+ start)))))))) + (split-from start)))) + +;; STRINGS + +(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(defun string-trim-whitespace (string) + (string-trim +whitespace+ string)) + +(defun string-right-trim-whitespace (string) + (string-right-trim +whitespace+ string)) + +(defun string-left-trim-whitespace (string) + (string-left-trim +whitespace+ string)) + +(defun split-string-at-char (string separator &key escape skip-empty) + "Split STRING at SEPARATORs and return a list of the substrings. If +SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is +not nil then split at SEPARATOR only if it's not preceded by ESCAPE." + (declare (type string string) (type character separator)) + (labels ((next-separator (beg) + (let ((pos (position separator string :start beg))) + (if (and escape + pos + (plusp pos) + (char= escape (char string (1- pos)))) + (next-separator (1+ pos)) + pos))) + (parse (beg) + (cond ((< beg (length string)) + (let* ((end (next-separator beg)) + (substring (subseq string beg end))) + (cond ((and skip-empty (string= "" substring)) + (parse (1+ end))) + ((not end) + (list substring)) + (t + (cons substring (parse (1+ end))))))) + (skip-empty + '()) + (t + (list ""))))) + (parse 0))) + +(defun s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(defun string-concat (list &optional (separator "")) + "Concatenate the strings in LIST interposing SEPARATOR (default +nothing) between them." + (reduce #'(lambda (&rest args) + (if args + (s+ (car args) separator (cadr args)) + "")) + list)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (let ((prefix-length (length prefix))) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +;; QUEUE + +(defstruct queue + first + last) + +(defgeneric queue-append (queue objects)) +(defgeneric queue-pop (queue)) +(defgeneric queue-empty-p (queue)) + +(defmethod queue-append ((queue queue) (objects list)) + (cond ((null (queue-first queue)) + (setf (queue-first queue) objects + (queue-last queue) (last objects))) + (t + (setf (cdr (queue-last queue)) objects + (queue-last queue) (last objects)))) + queue) + +(defmethod queue-append ((queue queue) object) + (queue-append queue (list object))) + +(defmethod queue-pop ((queue queue)) + (prog1 (car (queue-first queue)) + (setf (queue-first queue) (cdr (queue-first queue))))) + +(defmethod queue-empty-p ((queue queue)) + (null (queue-first queue))) + +;; STREAMS + +(defmacro save-file-excursion ((stream &optional position) &body forms) + "Execute FORMS returning, on exit, STREAM to the position it was +before FORMS. Optionally POSITION can be set to the starting offset." + (unless position + (setf position (gensym))) + `(let ((,position (file-position ,stream))) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (in pathname + :element-type element-type + :if-does-not-exist (unless (eq :value if-does-not-exist) + :error)) + (if in + (let ((seq (make-array (file-length in) :element-type element-type))) + (read-sequence seq in) + seq) + default))) + +;; FILES + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + #+sbcl (stat-size (unix-stat pathname)) + #-sbcl (error "nyi")) + +;; LAZY + +(defstruct promise + procedure + value) + +(defmacro lazy (form) + `(make-promise :procedure #'(lambda () ,form))) + +(defun forced-p (promise) + (null (promise-procedure promise))) + +(defun force (promise) + (if (forced-p promise) + (promise-value promise) + (prog1 (setf (promise-value promise) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) + +(defmacro deflazy (name value &optional documentation) + `(defparameter ,name (lazy ,value) + ,@(when documentation + (list documentation)))) + +;; FIXNUMS + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +;; TIME + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defvar +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp index 5639aab236..3cdac4b26b 100644 --- a/third_party/lisp/mime4cl/mime.lisp +++ b/third_party/lisp/mime4cl/mime.lisp @@ -1,7 +1,7 @@ ;;; mime4cl.lisp --- MIME primitives for Common Lisp ;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero -;;; Copyright (C) 2021 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -183,14 +183,11 @@ :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-stream (mime-part) + (make-input-adapter (mime-body mime-part))) (defun mime-body-length (mime-part) - (be body (mime-body mime-part) + (let ((body (mime-body mime-part))) ;; here the stream type is missing on purpose, because we may not ;; be able to size the length of a stream (etypecase body @@ -207,8 +204,8 @@ 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)) +(defmacro with-input-from-mime-body-stream ((stream part) &body forms) + `(with-open-stream (,stream (mime-body-stream ,part)) ,@forms)) (defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part)) @@ -302,12 +299,13 @@ semi-colons not within strings or comments." (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) + ;; TODO(sterni): when-let + (let ((equal-position (position #\= string))) (when equal-position - (be key (subseq string 0 equal-position) + (let ((key (subseq string 0 equal-position))) (if (= equal-position (1- (length string))) (cons key "") - (be value (string-trim-whitespace (subseq string (1+ equal-position))) + (let ((value (string-trim-whitespace (subseq string (1+ equal-position))))) (cons key (if (and (> (length value) 1) (char= #\" (elt value 0))) @@ -316,8 +314,8 @@ semi-colons not within strings or comments." ;; reader (or (ignore-errors (read-from-string value)) (subseq value 1)) - (be end (or (position-if #'whitespace-p value) - (length value)) + (let ((end (or (position-if #'whitespace-p value) + (length value)))) (subseq value 0 end)))))))))) (defun parse-content-type (string) @@ -340,7 +338,7 @@ Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." 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) + (let ((parts (split-header-parts string))) (cons (car parts) (mapcan #'(lambda (parameter-string) (awhen (parse-parameter parameter-string) (list it))) @@ -350,7 +348,7 @@ Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." "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) + (let ((colon (position #\: string))) (when colon (values (string-trim-whitespace (subseq string 0 colon)) (string-trim-whitespace (subseq string (1+ colon))))))) @@ -419,34 +417,6 @@ each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." 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." @@ -531,9 +501,9 @@ separated by PART-BOUNDARY." (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)))) + (let ((boundary (or (get-mime-type-parameter part :boundary) + (setf (get-mime-type-parameter part :boundary) + (choose-boundary (mime-parts part)))))) (dolist (p (mime-parts part)) (format stream "~%--~A~%" boundary) (encode-mime-part p stream)) @@ -588,7 +558,7 @@ found in STREAM." ;; 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) + for line = (let ((line (read-line stream nil))) ;; skip the Unix "From " header if present (if (string-starts-with "From " line) (read-line stream nil) @@ -641,19 +611,19 @@ found in STREAM." (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 flexi-stream)) + (let ((base (flexi-stream-root-stream stream))) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (etypecase base + (vector-stream + (flexi-streams::vector-stream-vector base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (flexi-stream-position stream) + :end (flexi-stream-bound stream))) + (call-next-method)))) (defmethod decode-mime-body ((part mime-part) (stream file-stream)) (if *lazy-mime-decode* @@ -663,12 +633,12 @@ found in STREAM." :start (file-position stream))) (call-next-method))) -(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream)) +(defmethod decode-mime-body ((part mime-part) (stream vector-stream)) (if *lazy-mime-decode* (setf (mime-body part) - (make-file-portion :data (stream-string stream) + (make-file-portion :data (flexi-streams::vector-stream-vector stream) :encoding (mime-encoding part) - :start (file-position stream))) + :start (flexi-streams::vector-stream-index stream))) (call-next-method))) (defmethod decode-mime-body ((part mime-part) stream) @@ -679,19 +649,18 @@ found in 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)) + (let ((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)))) + (let ((*default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii"))))) + (in (make-positioned-flexi-input-stream stream + :position start + :bound end + :ignore-close t))) + (read-mime-part in)))) offsets))))) (defmethod decode-mime-body ((part mime-message) stream) @@ -702,7 +671,7 @@ body." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) +(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) "List of known content encodings.") (defun keywordify-encoding (string) @@ -713,11 +682,11 @@ Return STRING itself if STRING is an unkown encoding." string)) (defun header (name headers) - (be elt (assoc name headers :test #'string-equal) + (let ((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) + (let ((entry (assoc name headers :test #'string-equal))) (unless entry (error "missing header ~A can't be set" name)) (setf (cdr entry) value))) @@ -729,7 +698,7 @@ guessed from the headers, use the *DEFAULT-TYPE*." (flet ((hdr (what) (header what headers))) (destructuring-bind (type subtype parms) - (or + (or (aand (hdr :content-type) (parse-content-type it)) *default-type*) @@ -755,16 +724,16 @@ guessed from the headers, use the *DEFAULT-TYPE*." (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)) + (let ((headers (read-rfc822-headers stream + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)))) (make-mime-part headers stream))) (defun read-mime-message (stream) "Main function to read a MIME message from a stream. It returns a MIME-MESSAGE object." - (be headers (read-rfc822-headers stream) - *default-type* '("text" "plain" (("charset" . "us-ascii"))) + (let ((headers (read-rfc822-headers stream)) + (*default-type* '("text" "plain" (("charset" . "us-ascii"))))) (flet ((hdr (what) (header what headers))) (destructuring-bind (type subtype parms) @@ -782,17 +751,21 @@ returns a MIME-MESSAGE object." msg) (defmethod mime-message ((msg string)) - (with-open-stream (in (make-instance 'my-string-input-stream :string msg)) - (read-mime-message in))) + (mime-message (flexi-streams:string-to-octets msg))) -(defmethod mime-message ((msg stream)) - (read-mime-message msg)) +(defmethod mime-message ((msg vector)) + (with-input-from-sequence (in msg) + (mime-message in))) (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)))) + (with-open-file (in msg :element-type '(unsigned-byte 8)) + (mime-message in))) + +(defmethod mime-message ((msg flexi-stream)) + (read-mime-message msg)) + +(defmethod mime-message ((msg stream)) + (read-mime-message (make-flexi-stream msg))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -815,15 +788,16 @@ returns a MIME-MESSAGE object." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod make-encoded-body-stream ((part mime-bodily-part)) - (be body (mime-body part) + (let ((body (mime-body part))) (make-instance (case (mime-encoding part) (:base64 'base64-encoder-input-stream) (:quoted-printable 'quoted-printable-encoder-input-stream) - (t + (otherwise '8bit-encoder-input-stream)) - :stream (make-instance 'binary-input-adapter-stream :source body)))) + :underlying-stream + (make-input-adapter body)))) (defun choose-boundary (parts &optional default) (labels ((match-in-parts (boundary parts) @@ -855,7 +829,7 @@ returns a MIME-MESSAGE object." ;; fall back method (defmethod mime-part-size ((part mime-part)) - (be body (mime-body part) + (let ((body (mime-body part))) (typecase body (pathname (file-size body)) @@ -882,7 +856,7 @@ returns a MIME-MESSAGE object." (case (mime-subtype part) (:alternative ;; try to choose something simple to print or the first thing - (be parts (mime-parts part) + (let ((parts (mime-parts part))) (print-mime-part (or (find-if #'(lambda (part) (and (eq (class-of part) (find-class 'mime-text)) (eq (mime-subtype part) :plain))) @@ -896,7 +870,7 @@ returns a MIME-MESSAGE object." ;; 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) + (let ((body (mime-body part))) (etypecase body (string (write-string body out)) @@ -950,8 +924,8 @@ second in MIME.")) (defmethod find-mime-part-by-path ((part mime-multipart) path) (if (null path) part - (be parts (mime-parts part) - part-number (car path) + (let ((parts (mime-parts part)) + (part-number (car path))) (if (<= 1 part-number (length parts)) (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path)) (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)." @@ -979,7 +953,7 @@ is a string.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod find-mime-text-part (msg) +(defgeneric find-mime-text-part (msg) (:documentation "Return message if it is a text message or first text part. If no suitable text part is found, return NIL.")) diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp index 5586bdc390..94b9e6b390 100644 --- a/third_party/lisp/mime4cl/package.lisp +++ b/third_party/lisp/mime4cl/package.lisp @@ -23,15 +23,7 @@ (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) + (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams :flexi-streams) (:export #:*lazy-mime-decode* #:print-mime-part #:read-mime-message @@ -74,11 +66,10 @@ #: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 + #:decode-RFC2047 #:parse-RFC822-header #:read-RFC822-headers #:time-RFC822-string @@ -91,7 +82,6 @@ #:with-input-from-mime-body-stream ;; endec.lisp #:base64-encoder - #:base64-decoder #:null-encoder #:null-decoder #:byte-encoder @@ -107,4 +97,7 @@ ;; 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)) + #:mailbox-group #:mbxg-name #:mbxg-mailboxes + ;; streams.lisp + #:redirect-stream + )) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp index dcac6ac341..71a32d84e4 100644 --- a/third_party/lisp/mime4cl/streams.lisp +++ b/third_party/lisp/mime4cl/streams.lisp @@ -1,7 +1,7 @@ ;;; streams.lisp --- En/De-coding Streams ;;; Copyright (C) 2012 by Walter C. Pelissero -;;; Copyright (C) 2021-2022 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -21,9 +21,17 @@ (in-package :mime4cl) +(defun flexi-stream-root-stream (stream) + "Return the non FLEXI-STREAM stream a given chain of FLEXI-STREAMs is based on." + (if (typep stream 'flexi-stream) + (flexi-stream-root-stream (flexi-stream-stream stream)) + stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defclass coder-stream-mixin () ((real-stream :type stream - :initarg :stream + :initarg :underlying-stream :reader real-stream) (dont-close :initform nil :initarg :dont-close))) @@ -39,9 +47,12 @@ (defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin) ()) +;; TODO(sterni): temporary, ugly measure to make flexi-streams happy +(defmethod stream-element-type ((stream coder-input-stream-mixin)) + (declare (ignore stream)) + '(unsigned-byte 8)) (defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ()) -(defclass 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) ()) @@ -52,7 +63,7 @@ (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."))) + (error "REAL-STREAM is unbound. Must provide a :UNDERLYING-STREAM argument."))) (defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys) (call-next-method) @@ -119,7 +130,7 @@ in a stream of character.")) (with-slots (encoder buffer-queue real-stream) stream (loop while (queue-empty-p buffer-queue) - do (be byte (read-byte real-stream nil) + do (let ((byte (read-byte real-stream nil))) (if byte (encoder-write-byte encoder byte) (progn @@ -136,220 +147,128 @@ in a stream of character.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(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) +(defun make-custom-flexi-stream (class stream other-args) + (apply #'make-instance + class + :stream stream + (mapcar (lambda (x) + ;; make-flexi-stream has a discrepancy between :initarg of + ;; make-instance and its &key which we mirror here. + (if (eq x :external-format) :flexi-stream-external-format x)) + other-args))) + +(defclass adapter-flexi-input-stream (flexi-input-stream) + ((ignore-close + :initform nil + :initarg :ignore-close + :documentation + "If T, calling CLOSE on the stream does nothing. +If NIL, the underlying stream is closed.")) + (:documentation "FLEXI-STREAM that does not close the underlying stream on +CLOSE if :IGNORE-CLOSE is T.")) + +(defmethod close ((stream adapter-flexi-input-stream) &key abort) + (declare (ignore abort)) + (with-slots (ignore-close) stream + (unless ignore-close + (call-next-method)))) + +(defun make-input-adapter (source) + (etypecase source + ;; If it's already a stream, we need to make sure it's not closed by the adapter + (stream + (assert (input-stream-p source)) + (if (and (typep source 'adapter-flexi-input-stream) + (slot-value source 'ignore-close)) + source ; already ignores CLOSE + (make-adapter-flexi-input-stream source :ignore-close t))) + ;; TODO(sterni): is this necessary? (maybe with (not *lazy-mime-decode*)?) + (string + (make-input-adapter (string-to-octets source))) + ((vector (unsigned-byte 8)) + (make-in-memory-input-stream source)) + (pathname + (make-flexi-stream (open source :element-type '(unsigned-byte 8)))) + (file-portion + (open-decoded-file-portion source)))) + +(defun make-adapter-flexi-input-stream (stream &rest args) + "Create a ADAPTER-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. If T, the underlying stream is not +closed." + (make-custom-flexi-stream 'adapter-flexi-input-stream stream args)) + +(defclass positioned-flexi-input-stream (adapter-flexi-input-stream) + () + (:documentation + "FLEXI-INPUT-STREAM that automatically advances the underlying :STREAM to +the location given by :POSITION. This uses FILE-POSITION internally, so it'll +only works if the underlying stream position is tracked in bytes. Note that +the underlying stream is still advanced, so having multiple instances of +POSITIONED-FLEXI-INPUT-STREAM based with the same underlying stream won't work +reliably. +Also supports :IGNORE-CLOSE of ADAPTER-FLEXI-INPUT-STREAM.")) + +(defmethod initialize-instance ((stream positioned-flexi-input-stream) + &key &allow-other-keys) (call-next-method) - (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))) + ;; The :POSITION initarg is only informational for flexi-streams: It assumes + ;; it is were the stream it got is already at and continuously updates it + ;; for querying (via FLEXI-STREAM-POSITION) and bound checking. + ;; Since we have streams that are not positioned correctly, we need to do this + ;; here using FILE-POSITION. Note that assumes the underlying implementation + ;; uses bytes for FILE-POSITION which is not guaranteed (probably some streams + ;; even in SBCL don't). + (file-position (flexi-stream-stream stream) (flexi-stream-position stream))) + +(defun make-positioned-flexi-input-stream (stream &rest args) + "Create a POSITIONED-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. Causes the FILE-POSITION of STREAM to +be modified to match the :POSITION argument." + (make-custom-flexi-stream 'positioned-flexi-input-stream stream args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TODO(sterni): test correct behavior with END NIL (defstruct file-portion - data ; string or a pathname + 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))) + (with-slots (data encoding start end) + file-portion + (let* ((binary-stream + (etypecase data + (pathname + (open data :element-type '(unsigned-byte 8))) + ((vector (unsigned-byte 8)) + (flexi-streams:make-in-memory-input-stream data)) + (stream + ;; TODO(sterni): assert that bytes/flexi-stream + data))) + (params (ccase encoding + ((:quoted-printable :base64) '(:external-format :us-ascii)) + (:8bit '(:element-type (unsigned-byte 8))) + (:7bit '(:external-format :us-ascii)))) + (portion-stream (apply #'make-positioned-flexi-input-stream + binary-stream + :position start + :bound end + ;; if data is a stream we can't have a + ;; FILE-PORTION without modifying it when + ;; reading etc. The least we can do, though, + ;; is forgo destroying it. + :ignore-close (typep data 'stream) + params)) + (needs-decoder-stream (member encoding '(:quoted-printable + :base64)))) + + (if needs-decoder-stream + (make-instance + (ccase encoding + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'qbase64:decode-stream)) + :underlying-stream portion-stream) + portion-stream)))) diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp index 5e8d43a7d4..6b22b3f6a2 100644 --- a/third_party/lisp/mime4cl/test/endec.lisp +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -103,13 +103,12 @@ line") (deftest base64.3 (map 'string #'code-char - (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) "Some random string.") (deftest base64.4 (map 'string #'code-char - (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" - :start 13 :end 41)) + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) "Some random string.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -118,6 +117,26 @@ line") (parse-RFC2047-text "foo bar") ("foo bar")) +;; from RFC2047 section 8 +(deftest RFC2047.2 + (decode-RFC2047 "=?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>") + "Keith Moore <moore@cs.utk.edu>") + +;; from RFC2047 section 8 +(deftest RFC2047.3 + (decode-RFC2047 "=?ISO-8859-1?Q?Olle_J=E4rnefors?=") + "Olle Järnefors") + +;; from RFC2047 section 8 +(deftest RFC2047.4 + (decode-RFC2047 "Nathaniel Borenstein <nsb@thumper.bellcore.com> (=?iso-8859-8?b?7eXs+SDv4SDp7Oj08A==?=)") + "Nathaniel Borenstein <nsb@thumper.bellcore.com> (םולש ןב ילטפנ)") + +;; from RFC2047 section 8 +(deftest RFC2047.5 + (decode-RFC2047 "=?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>") + "Keld Jørn Simonsen <keld@dkuug.dk>") + (defun perftest-encoder (encoder-class &optional (megs 100)) (declare (optimize (speed 3) (debug 0) (safety 0)) (type fixnum megs)) @@ -139,13 +158,12 @@ line") (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*) + (let ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) :type "encoded-data"))) - (sclf:with-temp-file (tmp nil :direction :io) + (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) diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp index 8d93978599..dbd1dd996d 100644 --- a/third_party/lisp/mime4cl/test/mime.lisp +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -1,7 +1,7 @@ ;;; mime.lisp --- MIME regression tests ;;; Copyright (C) 2012 by Walter C. Pelissero -;;; Copyright (C) 2021-2022 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -27,28 +27,15 @@ *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) +(loop + for f in (directory (make-pathname :defaults *samples-directory* + :name :wild + :type "msg")) + for i from 1 + do + (add-test (intern (format nil "MIME.~A" i)) + `(let* ((orig (mime-message ,f)) + (dup (mime-message + (with-output-to-string (out) (encode-mime-part orig out))))) + (mime= orig dup)) + t)) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp index 6da1fc8fa2..965680448f 100644 --- a/third_party/lisp/mime4cl/test/package.lisp +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -23,5 +23,5 @@ (defpackage :mime4cl-tests (:use :common-lisp - :rtest :mime4cl) + :rtest :mime4cl :mime4cl-ex-sclf) (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp index 06160debbe..3f3aa5c56c 100644 --- a/third_party/lisp/mime4cl/test/rt.lisp +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -1,5 +1,6 @@ #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | Copyright 2023 by the TVL Authors | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | @@ -20,10 +21,10 @@ |----------------------------------------------------------------------------|# (defpackage #:regression-test - (:nicknames #:rtest #-lispworks #:rt) + (:nicknames #:rtest #-lispworks #:rt) (:use #:cl) (:export #:*do-tests-when-defined* #:*test* #:continue-testing - #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:deftest #:add-test #:do-test #:do-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test) (:documentation "The MIT regression tester with pfdietz's modifications")) @@ -86,25 +87,28 @@ (defmacro deftest (name form &rest values) `(add-entry '(t ,name ,form .,values))) +(defun add-test (name form &rest values) + (funcall #'add-entry (append (list 't name form) values))) + (defun add-entry (entry) (setq entry (copy-list entry)) (do ((l *entries* (cdr l))) (nil) (when (null (cdr l)) (setf (cdr l) (list entry)) (return nil)) - (when (equal (name (cadr l)) + (when (equal (name (cadr l)) (name entry)) (setf (cadr l) entry) (report-error nil - "Redefining test ~:@(~S~)" - (name entry)) + "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* + (cond (*debug* (apply #'format t args) (if error? (throw '*debug* nil))) (error? (apply #'error args)) @@ -184,7 +188,7 @@ (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~ @@ -210,7 +214,7 @@ (setf (pend entry) t)) (if (streamp out) (do-entries out) - (with-open-file + (with-open-file (stream out :direction :output) (do-entries stream)))) diff --git a/third_party/lisp/mime4cl/test/sample1.msg b/third_party/lisp/mime4cl/test/samples/sample1.msg index 662a9fab34..662a9fab34 100644 --- a/third_party/lisp/mime4cl/test/sample1.msg +++ b/third_party/lisp/mime4cl/test/samples/sample1.msg diff --git a/third_party/lisp/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp new file mode 100644 index 0000000000..554f35844b --- /dev/null +++ b/third_party/lisp/mime4cl/test/temp-file.lisp @@ -0,0 +1,72 @@ +;;; temp-file.lisp --- temporary file creation + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl +;;; +;;; Code taken from SCLF + +#+cmu (ext:file-comment "$Module: temp-file.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defvar *tmp-file-defaults* #P"/tmp/") + +(defun temp-file-name (&optional (default *tmp-file-defaults*)) + "Create a random pathname based on DEFAULT. No effort is made +to make sure that the returned pathname doesn't identify an +already existing file. If missing DEFAULT defaults to +*TMP-FILE-DEFAULTS*." + (make-pathname :defaults default + :name (format nil "~36R" (random #.(expt 36 10))))) + +(defun open-temp-file (&optional default-pathname &rest open-args) + "Open a new temporary file and return a stream to it. This function +makes sure the pathname of the temporary file is unique. OPEN-ARGS +are arguments passed verbatim to OPEN. If OPEN-ARGS specify +the :DIRECTION it should be either :OUTPUT (default) or :IO; +any other value causes an error. If DEFAULT-PATHNAME is specified and +not NIL it's used as defaults to produce the pathname of the temporary +file, otherwise *TMP-FILE-DEFAULTS* is used." + (unless default-pathname + (setf default-pathname *tmp-file-defaults*)) + ;; if :DIRECTION is specified check that it's compatible with the + ;; purpose of this function, otherwise make it default to :OUTPUT + (aif (getf open-args :direction) + (unless (member it '(:output :io)) + (error "Can't create temporary file with open direction ~A." it)) + (setf open-args (append '(:direction :output) + open-args))) + (do* ((name #1=(temp-file-name default-pathname) #1#) + (stream #2=(apply #'open name + :if-exists nil + :if-does-not-exist :create + open-args) #2#)) + (stream stream))) + +(defmacro with-temp-file ((stream &rest open-temp-args) &body body) + "Execute BODY within a dynamic extent where STREAM is bound to +a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are +passed verbatim to OPEN-TEMP-FILE." + `(let ((,stream (open-temp-file ,@open-temp-args))) + (unwind-protect + (progn ,@body) + (close ,stream) + ;; body may decide to rename the file so we must ignore the errors + (ignore-errors + (delete-file (pathname ,stream)))))) diff --git a/third_party/lisp/npg/OWNERS b/third_party/lisp/npg/OWNERS index f16dd105d7..2e95807063 100644 --- a/third_party/lisp/npg/OWNERS +++ b/third_party/lisp/npg/OWNERS @@ -1,3 +1 @@ -inherited: true -owners: - - sterni +sterni diff --git a/third_party/lisp/qbase64/coreutils-base64.patch b/third_party/lisp/qbase64/coreutils-base64.patch new file mode 100644 index 0000000000..5a2f2a9f08 --- /dev/null +++ b/third_party/lisp/qbase64/coreutils-base64.patch @@ -0,0 +1,13 @@ +diff --git a/qbase64-test.lisp b/qbase64-test.lisp +index 310fdf3..b92abb5 100644 +--- a/qbase64-test.lisp ++++ b/qbase64-test.lisp +@@ -14,7 +14,7 @@ + (with-open-temporary-file (tmp :direction :output :element-type '(unsigned-byte 8)) + (write-sequence bytes tmp) + (force-output tmp) +- (let* ((encoded (uiop:run-program `("base64" "-b" ,(format nil "~A" linebreak) "-i" ,(namestring tmp)) :output (if (zerop linebreak) '(:string :stripped t) :string))) ++ (let* ((encoded (uiop:run-program `("base64" "-w" ,(format nil "~A" linebreak) ,(namestring tmp)) :output (if (zerop linebreak) '(:string :stripped t) :string) :error-output *error-output*)) + (length (length encoded))) + (cond ((and (> length 1) + (string= (subseq encoded (- length 2)) diff --git a/third_party/lisp/qbase64/default.nix b/third_party/lisp/qbase64/default.nix new file mode 100644 index 0000000000..40a93e04f0 --- /dev/null +++ b/third_party/lisp/qbase64/default.nix @@ -0,0 +1,57 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + src = pkgs.fetchFromGitHub { + owner = "chaitanyagupta"; + repo = "qbase64"; + rev = "4ac193ed6b35a867ca453ed74acc128c9a077407"; + sha256 = "06daqqfdd51wkx0pyxgz7zq4ibzsqsgn3qs04jabx67gyybgnmjm"; + }; + + patches = [ + # qbase64 expects macOS base64 + ./coreutils-base64.patch + ]; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); + +in + +depot.nix.buildLisp.library { + name = "qbase64"; + + srcs = getSrcs [ + "package.lisp" + "utils.lisp" + "stream-utils.lisp" + "qbase64.lisp" + ]; + + deps = [ + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.metabang-bind + ]; + + tests = { + name = "qbase64-tests"; + + srcs = getSrcs [ + "qbase64-test.lisp" + ]; + + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + depot.third_party.lisp.fiveam + depot.third_party.lisp.cl-fad + ]; + + expression = '' + (fiveam:run! '(qbase64-test::encoder 'qbase64-test::decoder)) + ''; + }; +} diff --git a/third_party/lisp/sclf/.skip-subtree b/third_party/lisp/sclf/.skip-subtree deleted file mode 100644 index 5051f60d6b..0000000000 --- a/third_party/lisp/sclf/.skip-subtree +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index f16dd105d7..0000000000 --- a/third_party/lisp/sclf/OWNERS +++ /dev/null @@ -1,3 +0,0 @@ -inherited: true -owners: - - sterni diff --git a/third_party/lisp/sclf/README b/third_party/lisp/sclf/README deleted file mode 100644 index 2a1c2c3c5c..0000000000 --- a/third_party/lisp/sclf/README +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index fb07f8f764..0000000000 --- a/third_party/lisp/sclf/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -# 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 deleted file mode 100644 index 3e479c4ac2..0000000000 --- a/third_party/lisp/sclf/directory.lisp +++ /dev/null @@ -1,404 +0,0 @@ -;;; 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 deleted file mode 100644 index 34bae82ebb..0000000000 --- a/third_party/lisp/sclf/lazy.lisp +++ /dev/null @@ -1,134 +0,0 @@ -;;; 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 deleted file mode 100644 index a0732c0294..0000000000 --- a/third_party/lisp/sclf/mp/README +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 1bdbba7989..0000000000 --- a/third_party/lisp/sclf/mp/cmu.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;; -;;; 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 deleted file mode 100644 index a2cf497ff9..0000000000 --- a/third_party/lisp/sclf/mp/sbcl.lisp +++ /dev/null @@ -1,235 +0,0 @@ -;;; -;;; 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 deleted file mode 100644 index 565ab301c7..0000000000 --- a/third_party/lisp/sclf/package.lisp +++ /dev/null @@ -1,258 +0,0 @@ -;;; 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 deleted file mode 100644 index a9754b7569..0000000000 --- a/third_party/lisp/sclf/sclf.asd +++ /dev/null @@ -1,58 +0,0 @@ -;;; 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 deleted file mode 100644 index dfbc2078c8..0000000000 --- a/third_party/lisp/sclf/sclf.lisp +++ /dev/null @@ -1,1717 +0,0 @@ -;;; 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 deleted file mode 100644 index 41d32e4c49..0000000000 --- a/third_party/lisp/sclf/serial.lisp +++ /dev/null @@ -1,62 +0,0 @@ - ;;; 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 deleted file mode 100644 index 1dd559ebe3..0000000000 --- a/third_party/lisp/sclf/sysproc.lisp +++ /dev/null @@ -1,295 +0,0 @@ -;;; 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 deleted file mode 100644 index 71b943aa43..0000000000 --- a/third_party/lisp/sclf/time.lisp +++ /dev/null @@ -1,311 +0,0 @@ -;;; 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/str.nix b/third_party/lisp/str.nix new file mode 100644 index 0000000000..556f9cc307 --- /dev/null +++ b/third_party/lisp/str.nix @@ -0,0 +1,49 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.str; +in +buildLisp.library { + name = "str"; + + deps = with depot.third_party.lisp; [ + { + sbcl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + cl-ppcre + cl-ppcre.unicode + cl-change-case + ]; + + srcs = [ + (pkgs.runCommand "str.lisp" { } '' + substitute ${src}/str.lisp $out \ + --replace-fail \ + '(asdf:component-version (asdf:find-system "str"))' \ + '"${pkgs.lispPackages.str.meta.version}"' + '') + ]; + + brokenOn = [ + "ccl" # In REPLACE-USING: Shouldn't assign to variable I + ]; + + tests = { + name = "str-test"; + srcs = [ (src + "/test/test-str.lisp") ]; + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + depot.third_party.lisp.prove + depot.third_party.lisp.fiveam + ]; + + expression = '' + (fiveam:run! 'str::test-str) + ''; + }; +} |