diff options
| author | sterni <sternenseemann@systemli.org> | 2022-01-19T13·39+0100 |
|---|---|---|
| committer | sterni <sternenseemann@systemli.org> | 2022-01-26T17·43+0000 |
| commit | 25cb0ad32ff197092262c74e944d254e901632bd (patch) | |
| tree | 68b70050e7ea3fd7912849292be03d289864acd3 /third_party/lisp | |
| parent | 40014c70b3b3545d2304411cb91b176d1a3e22d2 (diff) | |
style(3p/lisp): expand tabs in npg, mime4cl and sclf r/3675
Done using
find third_party/lisp/{sclf,mime4cl,npg} \
-name '*.lisp' -or -name '*.asd' \
-exec bash -c 'expand -i -t 8 "$0" | sponge "$0"' {} \;
Change-Id: If84afac9c1d5cbc74e137a5aa0ae61472f0f1e90
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5066
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
Diffstat (limited to 'third_party/lisp')
25 files changed, 2467 insertions, 2467 deletions
diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp index 9a3bec9b20..4f4cda2434 100644 --- a/third_party/lisp/mime4cl/address.lisp +++ b/third_party/lisp/mime4cl/address.lisp @@ -101,10 +101,10 @@ (defun parser-make-mailbox (description address-list) (make-mailbox :description description - :user (car address-list) - :host (cadr address-list) - :domain (when (cddr address-list) - (string-concat (cddr address-list) ".")))) + :user (car address-list) + :host (cadr address-list) + :domain (when (cddr address-list) + (string-concat (cddr address-list) ".")))) (defun populate-grammar () @@ -164,7 +164,7 @@ (deflazy define-grammar (let ((*package* #.*package*) - (*compile-print* (when npg::*debug* t))) + (*compile-print* (when npg::*debug* t))) (reset-grammar) (format t "~&creating e-mail address grammar...~%") (populate-grammar) @@ -183,36 +183,36 @@ (defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\)) (labels ((collect () - (with-output-to-string (out) - (loop - for c = (read-char stream nil) - while (and c (not (char= c end-char))) - do (cond ((char= c escape-char) - (awhen (read-char stream nil) - (write-char it out))) - ((and nesting-start-char - (char= c nesting-start-char)) - (write-char nesting-start-char out) - (write-string (collect) out) - (write-char end-char out)) - (t (write-char c out))))))) + (with-output-to-string (out) + (loop + for c = (read-char stream nil) + while (and c (not (char= c end-char))) + do (cond ((char= c escape-char) + (awhen (read-char stream nil) + (write-char it out))) + ((and nesting-start-char + (char= c nesting-start-char)) + (write-char nesting-start-char out) + (write-string (collect) out) + (write-char end-char out)) + (t (write-char c out))))))) (collect))) (defun read-string (cursor) (make-token :type 'string - :value (read-delimited-string (cursor-stream cursor) #\") - :position (incf (cursor-position cursor)))) + :value (read-delimited-string (cursor-stream cursor) #\") + :position (incf (cursor-position cursor)))) (defun read-domain-literal (cursor) (make-token :type 'domain-literal - :value (read-delimited-string (cursor-stream cursor) #\]) - :position (incf (cursor-position cursor)))) + :value (read-delimited-string (cursor-stream cursor) #\]) + :position (incf (cursor-position cursor)))) (defun read-comment (cursor) (make-token :type 'comment - :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\() - :position (incf (cursor-position cursor)))) + :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\() + :position (incf (cursor-position cursor)))) (declaim (inline atom-component-p)) (defun atom-component-p (c) @@ -221,40 +221,40 @@ (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))))) + (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))))) + :value string + :position (incf (cursor-position cursor))))) (defmethod read-next-tokens ((cursor cursor)) (flet ((make-keyword (c) - (make-token :type 'keyword - :value (string c) - :position (incf (cursor-position cursor))))) + (make-token :type 'keyword + :value (string c) + :position (incf (cursor-position cursor))))) (be in (cursor-stream cursor) (loop - for c = (read-char in nil) - while c - unless (whitespace-p c) - return (list - (cond ((char= #\( c) - (read-comment cursor)) - ((char= #\" c) - (read-string cursor)) - ((char= #\[ c) - (read-domain-literal cursor)) - ((find c "@.<>:;,") - (make-keyword c)) - (t - ;; anything else is considered a text atom even - ;; though it's just a single character - (read-atext c cursor)))))))) + for c = (read-char in nil) + while c + unless (whitespace-p c) + return (list + (cond ((char= #\( c) + (read-comment cursor)) + ((char= #\" c) + (read-string cursor)) + ((char= #\[ c) + (read-domain-literal cursor)) + ((find c "@.<>:;,") + (make-keyword c)) + (t + ;; anything else is considered a text atom even + ;; though it's just a single character + (read-atext c cursor)))))))) (defun analyse-string (string) "Return the list of tokens produced by a lexical analysis of @@ -262,9 +262,9 @@ STRING. These are the tokens that would be seen by the parser." (with-input-from-string (stream string) (be cursor (make-cursor :stream stream) (loop - for tokens = (read-next-tokens cursor) - until (endp tokens) - append tokens)))) + for tokens = (read-next-tokens cursor) + until (endp tokens) + append tokens)))) (defun mailboxes-only (list-of-mailboxes-and-groups) "Return a flat list of MAILBOX-ADDRESSes from @@ -273,10 +273,10 @@ by PARSE-ADDRESSES. This turns out to be useful when your program is not interested in mailbox groups and expects the user addresses only." (mapcan #'(lambda (mbx) - (if (typep mbx 'mailbox-group) - (mbxg-mailboxes mbx) - (list mbx))) - list-of-mailboxes-and-groups)) + (if (typep mbx 'mailbox-group) + (mbxg-mailboxes mbx) + (list mbx))) + list-of-mailboxes-and-groups)) (defun parse-addresses (string &key no-groups) "Parse STRING and return a list of MAILBOX-ADDRESSes or @@ -286,16 +286,16 @@ the group containers, if any." (be grammar (force define-grammar) (with-input-from-string (stream string) (be* cursor (make-cursor :stream stream) - mailboxes (ignore-errors ; ignore parsing errors - (parse grammar 'address-list cursor)) - (if no-groups - (mailboxes-only mailboxes) - mailboxes))))) + mailboxes (ignore-errors ; ignore parsing errors + (parse grammar 'address-list cursor)) + (if no-groups + (mailboxes-only mailboxes) + mailboxes))))) (defun debug-addresses (string) "More or less like PARSE-ADDRESSES, but don't ignore parsing errors." (be grammar (force define-grammar) (with-input-from-string (stream string) (be cursor (make-cursor :stream stream) - (parse grammar 'address-list cursor))))) + (parse grammar 'address-list cursor))))) diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp index f63eb3c22e..9f2f9c51c2 100644 --- a/third_party/lisp/mime4cl/endec.lisp +++ b/third_party/lisp/mime4cl/endec.lisp @@ -33,7 +33,7 @@ da)) (declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+) - (type simple-string +base64-encode-table+)) + (type simple-string +base64-encode-table+)) (defvar *base64-line-length* 76 "Maximum length of the encoded base64 line. NIL means it can @@ -49,39 +49,39 @@ by the encoding function).") (defclass decoder () ((input-function :initarg :input-function - :reader decoder-input-function - :type function - :documentation - "Function is called repeatedly by the decoder methods to get the next character. + :reader decoder-input-function + :type function + :documentation + "Function is called repeatedly by the decoder methods to get the next character. It should return a character os NIL (indicating EOF).")) (:documentation "Abstract base class for decoders.")) (defclass parsing-decoder (decoder) ((parser-errors :initform nil - :initarg :parser-errors - :reader decoder-parser-errors - :type boolean)) + :initarg :parser-errors + :reader decoder-parser-errors + :type boolean)) (:documentation "Abstract base class for decoders that do parsing.")) (defclass encoder () ((output-function :initarg :output-function - :reader encoder-output-function - :type function - :documentation - "Function is called repeatedly by the encoder methods to output a character. + :reader encoder-output-function + :type function + :documentation + "Function is called repeatedly by the encoder methods to output a character. It should expect a character as its only argument.")) (:documentation "Abstract base class for encoders.")) (defclass line-encoder (encoder) ((column :initform 0 - :type fixnum) + :type fixnum) (line-length :initarg :line-length - :initform nil - :reader encoder-line-length - :type (or fixnum null))) + :initform nil + :reader encoder-line-length + :type (or fixnum null))) (:documentation "Abstract base class for line encoders.")) @@ -126,7 +126,7 @@ It should expect a character as its only argument.")) (defmethod encoder-write-byte ((encoder 8bit-encoder) byte) (funcall (slot-value encoder 'output-function) - (code-char byte)) + (code-char byte)) (values)) (defmethod decoder-read-byte ((decoder 8bit-decoder)) @@ -135,7 +135,7 @@ It should expect a character as its only argument.")) (defmethod encoder-write-byte ((encoder 7bit-encoder) byte) (funcall (slot-value encoder 'output-function) - (code-char (logand #x7F byte))) + (code-char (logand #x7F byte))) (values)) (defmethod decoder-read-byte ((decoder 7bit-decoder)) @@ -146,8 +146,8 @@ It should expect a character as its only argument.")) (defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence))) (declare (optimize (speed 3) (safety 0) (debug 0)) - (type fixnum start end) - (type vector sequence)) + (type fixnum start end) + (type vector sequence)) (loop for i fixnum from start below end for byte = (decoder-read-byte decoder) @@ -162,14 +162,14 @@ It should expect a character as its only argument.")) unless byte do (return-from decoder-read-line nil) do (be c (code-char byte) - (cond ((char= c #\return) - ;; skip the newline - (decoder-read-byte decoder) - (return nil)) - ((char= c #\newline) - ;; the #\return was missing - (return nil)) - (t (write-char c str))))))) + (cond ((char= c #\return) + ;; skip the newline + (decoder-read-byte decoder) + (return nil)) + ((char= c #\newline) + ;; the #\return was missing + (return nil)) + (t (write-char c str))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -178,10 +178,10 @@ It should expect a character as its only argument.")) "Parse two characters as hexadecimal and return their combined value." (declare (optimize (speed 3) (safety 0) (debug 0)) - (type character c1 c2)) + (type character c1 c2)) (flet ((digit-value (char) - (or (position char "0123456789ABCDEF") - (return-from parse-hex nil)))) + (or (position char "0123456789ABCDEF") + (return-from parse-hex nil)))) (+ (* 16 (digit-value c1)) (digit-value c2)))) @@ -193,91 +193,91 @@ value." (with-slots (input-function saved-bytes parser-errors) decoder (declare (type function input-function)) (labels ((saveb (b) - (queue-append saved-bytes b) - (values)) - (save (c) - (saveb (char-code c))) - (push-next () - (be c (funcall input-function) - (declare (type (or null character) c)) - (cond ((not c)) - ((or (char= c #\space) - (char= c #\tab)) - (save c) - (push-next)) - ((char= c #\=) - (be c1 (funcall input-function) - (cond ((not c1) - (save #\=)) - ((char= c1 #\return) - ;; soft line break: skip the next - ;; character which we assume to be a - ;; newline (pity if it isn't) - (funcall input-function) - (push-next)) - ((char= c1 #\newline) - ;; soft line break: the #\return is - ;; missing, but we are tolerant - (push-next)) - (t - ;; hexadecimal sequence: get the 2nd digit - (be c2 (funcall input-function) - (if c2 - (aif (parse-hex c1 c2) - (saveb it) - (if parser-errors - (error "invalid hex sequence ~A~A" c1 c2) - (progn - (save #\=) - (save c1) - (save c2)))) - (progn - (save c) - (save c1)))))))) - (t - (save c)))))) + (queue-append saved-bytes b) + (values)) + (save (c) + (saveb (char-code c))) + (push-next () + (be c (funcall input-function) + (declare (type (or null character) c)) + (cond ((not c)) + ((or (char= c #\space) + (char= c #\tab)) + (save c) + (push-next)) + ((char= c #\=) + (be c1 (funcall input-function) + (cond ((not c1) + (save #\=)) + ((char= c1 #\return) + ;; soft line break: skip the next + ;; character which we assume to be a + ;; newline (pity if it isn't) + (funcall input-function) + (push-next)) + ((char= c1 #\newline) + ;; soft line break: the #\return is + ;; missing, but we are tolerant + (push-next)) + (t + ;; hexadecimal sequence: get the 2nd digit + (be c2 (funcall input-function) + (if c2 + (aif (parse-hex c1 c2) + (saveb it) + (if parser-errors + (error "invalid hex sequence ~A~A" c1 c2) + (progn + (save #\=) + (save c1) + (save c2)))) + (progn + (save c) + (save c1)))))))) + (t + (save c)))))) (or (queue-pop saved-bytes) - (progn - (push-next) - (queue-pop saved-bytes)))))) + (progn + (push-next) + (queue-pop saved-bytes)))))) (defmacro make-encoder-loop (encoder-class input-form output-form) (with-gensyms (encoder byte) `(loop - with ,encoder = (make-instance ',encoder-class - :output-function #'(lambda (char) ,output-form)) - for ,byte = ,input-form - while ,byte - do (encoder-write-byte ,encoder ,byte) - finally (encoder-finish-output ,encoder)))) + with ,encoder = (make-instance ',encoder-class + :output-function #'(lambda (char) ,output-form)) + for ,byte = ,input-form + while ,byte + do (encoder-write-byte ,encoder ,byte) + finally (encoder-finish-output ,encoder)))) (defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors) (with-gensyms (decoder) `(loop - with ,decoder = (make-instance ',decoder-class - :input-function #'(lambda () ,input-form) - :parser-errors ,parser-errors) - for byte = (decoder-read-byte ,decoder) - while byte - do ,output-form))) + with ,decoder = (make-instance ',decoder-class + :input-function #'(lambda () ,input-form) + :parser-errors ,parser-errors) + for byte = (decoder-read-byte ,decoder) + while byte + do ,output-form))) (defun decode-quoted-printable-stream (in out &key parser-errors) "Read from stream IN a quoted printable text and write to binary output OUT the decoded stream of bytes." (make-decoder-loop quoted-printable-decoder - (read-byte in nil) (write-byte byte out) - :parser-errors parser-errors)) + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) (defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors) "Decode the character stream STREAM and return a sequence of bytes." (with-gensyms (output-sequence) `(be ,output-sequence (make-array 0 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t) + :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) + (vector-push-extend byte ,output-sequence) + :parser-errors ,parser-errors) ,output-sequence))) (defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors) @@ -295,84 +295,84 @@ return a decoded sequence of bytes." (defclass quoted-printable-encoder (line-encoder) ((line-length :initform *quoted-printable-line-length* - :type (or fixnum null)) + :type (or fixnum null)) (pending-space :initform nil - :type boolean))) + :type boolean))) (defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte) (declare (optimize (speed 3) (safety 0) (debug 0)) - (type (unsigned-byte 8) byte)) + (type (unsigned-byte 8) byte)) (with-slots (output-function column pending-space line-length) encoder (declare (type function output-function) - (type fixnum column) - (type (or fixnum null) line-length) - (type boolean pending-space)) + (type fixnum column) + (type (or fixnum null) line-length) + (type boolean pending-space)) (labels ((out (c) - (funcall output-function c) - (values)) - (outs (str) - (declare (type simple-string str)) - (loop - for c across str - do (out c)) - (values)) - (out2hex (x) - (declare (type fixnum x)) - (multiple-value-bind (a b) (truncate x 16) - (out (digit-char a 16)) - (out (digit-char b 16))))) + (funcall output-function c) + (values)) + (outs (str) + (declare (type simple-string str)) + (loop + for c across str + do (out c)) + (values)) + (out2hex (x) + (declare (type fixnum x)) + (multiple-value-bind (a b) (truncate x 16) + (out (digit-char a 16)) + (out (digit-char b 16))))) (cond ((= byte #.(char-code #\newline)) - (when pending-space - (outs "=20") - (setf pending-space nil)) - (out #\newline) - (setf column 0)) - ((= byte #.(char-code #\space)) - (if pending-space - (progn - (out #\space) - (f++ column)) - (setf pending-space t))) - (t - (when pending-space - (out #\space) - (f++ column) - (setf pending-space nil)) - (cond ((or (< byte 32) - (= byte #.(char-code #\=)) - (> byte 126)) - (out #\=) - (out2hex byte) - (f++ column 3)) - (t - (out (code-char byte)) - (f++ column))))) + (when pending-space + (outs "=20") + (setf pending-space nil)) + (out #\newline) + (setf column 0)) + ((= byte #.(char-code #\space)) + (if pending-space + (progn + (out #\space) + (f++ column)) + (setf pending-space t))) + (t + (when pending-space + (out #\space) + (f++ column) + (setf pending-space nil)) + (cond ((or (< byte 32) + (= byte #.(char-code #\=)) + (> byte 126)) + (out #\=) + (out2hex byte) + (f++ column 3)) + (t + (out (code-char byte)) + (f++ column))))) (when (and line-length - (>= column line-length)) - ;; soft line break - (outs #.(coerce '(#\= #\newline) 'string)) - (setf column 0))))) + (>= column line-length)) + ;; soft line break + (outs #.(coerce '(#\= #\newline) 'string)) + (setf column 0))))) (defmethod encoder-finish-output ((encoder quoted-printable-encoder)) (declare (optimize (speed 3) (safety 0) (debug 0))) (with-slots (pending-space output-function) encoder (declare (type boolean pending-space) - (type function output-function)) + (type function output-function)) (when pending-space (flet ((outs (s) - (declare (type simple-string s)) - (loop - for c across s - do (funcall output-function c)))) - (setf pending-space nil) - (outs "=20"))))) + (declare (type simple-string s)) + (loop + for c across s + do (funcall output-function c)))) + (setf pending-space nil) + (outs "=20"))))) (defun encode-quoted-printable-stream (in out) "Read from IN a stream of bytes and write to OUT a stream of characters quoted printables encoded." (make-encoder-loop quoted-printable-encoder - (read-byte in nil) - (write-char char out))) + (read-byte in nil) + (write-char char out))) (defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) "Encode the sequence of bytes SEQUENCE and write to STREAM a @@ -381,7 +381,7 @@ quoted printable sequence of characters." (make-encoder-loop quoted-printable-encoder (when (< i end) (prog1 (elt sequence i) - (f++ i))) + (f++ i))) (write-char char stream)))) (defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence))) @@ -395,9 +395,9 @@ string and return it." (defclass base64-encoder (line-encoder) ((line-length :initform *base64-line-length*) (bitstore :initform 0 - :type fixnum) + :type fixnum) (bytecount :initform 0 - :type fixnum)) + :type fixnum)) (:documentation "Class for Base64 encoder output streams.")) @@ -406,76 +406,76 @@ string and return it." (unless (> most-positive-fixnum (expt 2 (* 8 3))))) (macrolet ((with-encoder (encoder &body forms) - `(with-slots (bitstore line-length column bytecount output-function) ,encoder - (declare (type fixnum column) - (type fixnum bitstore bytecount) - (type (or fixnum null) line-length) - (type function output-function)) - (labels ((emitr (i b) - (declare (type fixnum i b)) - (unless (zerop i) - (emitr (1- i) (ash b -6))) - (emitc - (char +base64-encode-table+ (logand b #x3F))) - (values)) - (out (c) - (funcall output-function c)) - (eol () - (progn - (out #\return) - (out #\newline))) - (emitc (char) - (out char) - (f++ column) - (when (and line-length - (>= column line-length)) - (setf column 0) - (eol)))) - (declare (inline out eol emitc) - (ignorable (function emitr) (function out) (function eol) (function emitc))) - ,@forms)))) + `(with-slots (bitstore line-length column bytecount output-function) ,encoder + (declare (type fixnum column) + (type fixnum bitstore bytecount) + (type (or fixnum null) line-length) + (type function output-function)) + (labels ((emitr (i b) + (declare (type fixnum i b)) + (unless (zerop i) + (emitr (1- i) (ash b -6))) + (emitc + (char +base64-encode-table+ (logand b #x3F))) + (values)) + (out (c) + (funcall output-function c)) + (eol () + (progn + (out #\return) + (out #\newline))) + (emitc (char) + (out char) + (f++ column) + (when (and line-length + (>= column line-length)) + (setf column 0) + (eol)))) + (declare (inline out eol emitc) + (ignorable (function emitr) (function out) (function eol) (function emitc))) + ,@forms)))) ;; For this function to work correctly, the FIXNUM must be at least ;; 24 bits. (defmethod encoder-write-byte ((encoder base64-encoder) byte) (declare (optimize (speed 3) (safety 0) (debug 0)) - (type (unsigned-byte 8) byte)) + (type (unsigned-byte 8) byte)) (with-encoder encoder (setf bitstore (logior byte (the fixnum (ash bitstore 8)))) (f++ bytecount) (when (= 3 bytecount) - (emitr 3 bitstore) - (setf bitstore 0 - bytecount 0))) + (emitr 3 bitstore) + (setf bitstore 0 + bytecount 0))) (values)) (defmethod encoder-finish-output ((encoder base64-encoder)) (with-encoder encoder (unless (zerop bytecount) - (multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6) - (setf bitstore (ash bitstore (- 6 rest))) - (emitr saved6 bitstore) - (dotimes (x (- 3 saved6)) - (emitc #\=)))) + (multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6) + (setf bitstore (ash bitstore (- 6 rest))) + (emitr saved6 bitstore) + (dotimes (x (- 3 saved6)) + (emitc #\=)))) (when (and line-length - (not (zerop column))) - (eol))) + (not (zerop column))) + (eol))) (values))) (defun encode-base64-stream (in out) "Read a byte stream from IN and write to OUT the encoded Base64 character stream." (make-encoder-loop base64-encoder (read-byte in nil) - (write-char char out))) + (write-char char out))) (defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) "Encode the sequence of bytes SEQUENCE and write to STREAM the Base64 character sequence." (be i start (make-encoder-loop base64-encoder - (when (< i end) - (prog1 (elt sequence i) - (incf i))) - (write-char char stream)))) + (when (< i end) + (prog1 (elt sequence i) + (incf i))) + (write-char char stream)))) (defun encode-base64-sequence (sequence &key (start 0) (end (length sequence))) "Encode the sequence of bytes SEQUENCE into a Base64 string and @@ -485,7 +485,7 @@ return it." (defclass base64-decoder (parsing-decoder) ((bitstore :initform 0 - :type fixnum) + :type fixnum) (bytecount :initform 0 :type fixnum)) (:documentation "Class for Base64 decoder input streams.")) @@ -494,45 +494,45 @@ return it." (declare (optimize (speed 3) (safety 0) (debug 0))) (with-slots (bitstore bytecount input-function) decoder (declare (type fixnum bitstore bytecount) - (type function input-function)) + (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)))))) + (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)))))) + (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)) + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) (defun decode-base64-stream-to-sequence (stream &key parser-errors) (make-stream-to-sequence-decoder base64-decoder - (read-char stream nil) - :parser-errors parser-errors)) + (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) @@ -551,10 +551,10 @@ to OUT a stream of decoded bytes." (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-stream in out - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (:base64 (decode-base64-stream in out - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (otherwise (dump-stream-binary in out)))) @@ -562,10 +562,10 @@ to OUT a stream of decoded bytes." (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-string string - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (:base64 (decode-base64-string string - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (otherwise (map '(vector (unsigned-byte 8)) #'char-code string)))) @@ -573,19 +573,19 @@ to OUT a stream of decoded bytes." (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-stream-to-sequence stream - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (:base64 (decode-base64-stream-to-sequence stream - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (otherwise (loop - with output-sequence = (make-array 0 :fill-pointer 0 - :element-type '(unsigned-byte 8) - :adjustable t) - for c = (read-char stream nil) - while c - do (vector-push-extend (char-code c) output-sequence) - finally (return output-sequence))))) + with output-sequence = (make-array 0 :fill-pointer 0 + :element-type '(unsigned-byte 8) + :adjustable t) + for c = (read-char stream nil) + while c + do (vector-push-extend (char-code c) output-sequence) + finally (return output-sequence))))) (defun encode-stream (in out encoding) (gcase (encoding string-equal) @@ -595,9 +595,9 @@ to OUT a stream of decoded bytes." (encode-base64-stream in out)) (otherwise (loop - for byte = (read-byte in nil) - while byte - do (write-char (code-char byte) out))))) + for byte = (read-byte in nil) + while byte + do (write-char (code-char byte) out))))) (defun encode-sequence-to-stream (sequence out encoding) (gcase (encoding string-equal) @@ -607,8 +607,8 @@ to OUT a stream of decoded bytes." (encode-base64-sequence-to-stream sequence out)) (otherwise (loop - for byte across sequence - do (write-char (code-char byte) out))))) + for byte across sequence + do (write-char (code-char byte) out))))) (defun encode-sequence (sequence encoding) (gcase (encoding string-equal) @@ -625,23 +625,23 @@ to OUT a stream of decoded bytes." "Decode a string encoded according to the quoted printable method of RFC2047 and return a sequence of bytes." (declare (optimize (speed 3) (debug 0) (safety 0)) - (type simple-string string)) + (type simple-string string)) (loop with output-sequence = (make-array (length string) - :element-type '(unsigned-byte 8) - :fill-pointer 0) + :element-type '(unsigned-byte 8) + :fill-pointer 0) for i fixnum from start by 1 below end for c = (char string i) do (case c - (#\= - (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i))) - ;; the char code was malformed - #.(char-code #\?)) - output-sequence) - (f++ i 2)) - (#\_ (vector-push-extend #.(char-code #\space) output-sequence)) - (otherwise - (vector-push-extend (char-code c) output-sequence))) + (#\= + (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i))) + ;; the char code was malformed + #.(char-code #\?)) + output-sequence) + (f++ i 2)) + (#\_ (vector-push-extend #.(char-code #\space) output-sequence)) + (otherwise + (vector-push-extend (char-code c) output-sequence))) finally (return output-sequence))) (defun decode-RFC2047-string (encoding string &key (start 0) (end (length string))) @@ -669,15 +669,15 @@ sequence, a charset string indicating the original coding." for end = (search "?=" text :start2 (1+ second-?)) while end do (let ((charset (string-upcase (subseq text (+ 2 start) first-?))) - (encoding (subseq text (1+ first-?) second-?))) - (unless (= previous-end start) - (push (subseq text previous-end start) - result)) - (setf previous-end (+ end 2)) - (push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end) - charset) - result)) + (encoding (subseq text (1+ first-?) second-?))) + (unless (= previous-end start) + (push (subseq text previous-end start) + result)) + (setf previous-end (+ end 2)) + (push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end) + charset) + result)) finally (unless (= previous-end (length text)) - (push (subseq text previous-end (length text)) - result)) + (push (subseq text previous-end (length text)) + result)) (return (nreverse result)))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp index e35ae6bea5..1b1d98bfaf 100644 --- a/third_party/lisp/mime4cl/mime.lisp +++ b/third_party/lisp/mime4cl/mime.lisp @@ -99,15 +99,15 @@ (defclass mime-multipart (mime-part) ((parts :initarg :parts - :accessor mime-parts))) + :accessor mime-parts))) (defclass mime-message (mime-part) ((headers :initarg :headers - :initform '() - :type list - :accessor mime-message-headers) + :initform '() + :type list + :accessor mime-message-headers) (real-message :initarg :body - :accessor mime-body))) + :accessor mime-body))) (defun mime-part-p (object) (typep object 'mime-part)) @@ -120,11 +120,11 @@ (with-slots (parts) part (when (slot-boundp part 'parts) (setf parts - (mapcar #'(lambda (subpart) - (if (mime-part-p subpart) - subpart - (apply #'make-instance subpart))) - parts))))) + (mapcar #'(lambda (subpart) + (if (mime-part-p subpart) + subpart + (apply #'make-instance subpart))) + parts))))) (defmethod initialize-instance ((part mime-message) &key &allow-other-keys) (call-next-method) @@ -133,18 +133,18 @@ ;; and assign to the body slot. (with-slots (real-message) part (when (and (slot-boundp part 'real-message) - (consp real-message)) + (consp real-message)) (setf real-message - (make-instance 'mime-multipart :parts real-message))))) + (make-instance 'mime-multipart :parts real-message))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun alist= (alist1 alist2 &key (test #'eql)) (null (set-difference alist1 alist2 - :test #'(lambda (x y) - (and (funcall test (car x) (car y)) - (funcall test (cdr x) (cdr y))))))) + :test #'(lambda (x y) + (and (funcall test (car x) (car y)) + (funcall test (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -154,24 +154,24 @@ (defmethod mime= ((part1 mime-part) (part2 mime-part)) (macrolet ((null-or (compare x y) - `(or (and (not ,x) - (not ,y)) - (and ,x ,y - (,compare ,x ,y)))) - (cmp-slot (compare reader) - `(null-or ,compare (,reader part1) (,reader part2)))) + `(or (and (not ,x) + (not ,y)) + (and ,x ,y + (,compare ,x ,y)))) + (cmp-slot (compare reader) + `(null-or ,compare (,reader part1) (,reader part2)))) (and (eq (class-of part1) (class-of part2)) - (cmp-slot string-equal mime-subtype) - (alist= (mime-type-parameters part1) - (mime-type-parameters part2) - :test #'string-equal) - (cmp-slot string= mime-id) - (cmp-slot string= mime-description) - (cmp-slot eq mime-encoding) - (cmp-slot equal mime-disposition) - (alist= (mime-disposition-parameters part1) - (mime-disposition-parameters part2) - :test #'string-equal)))) + (cmp-slot string-equal mime-subtype) + (alist= (mime-type-parameters part1) + (mime-type-parameters part2) + :test #'string-equal) + (cmp-slot string= mime-id) + (cmp-slot string= mime-description) + (cmp-slot eq mime-encoding) + (cmp-slot equal mime-disposition) + (alist= (mime-disposition-parameters part1) + (mime-disposition-parameters part2) + :test #'string-equal)))) (defmethod mime= ((part1 mime-multipart) (part2 mime-multipart)) (and (call-next-method) @@ -180,14 +180,14 @@ (defmethod mime= ((part1 mime-message) (part2 mime-message)) (and (call-next-method) (alist= (mime-message-headers part1) (mime-message-headers part2) - :test #'string=) + :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))) + 'binary-input-adapter-stream + 'character-input-adapter-stream) + :source (mime-body mime-part))) (defun mime-body-length (mime-part) (be body (mime-body mime-part) @@ -202,10 +202,10 @@ (file-size body)) (file-portion (with-open-stream (in (open-decoded-file-portion body)) - (loop - for byte = (read-byte in nil) - while byte - count byte)))))) + (loop + for byte = (read-byte in nil) + while byte + count byte)))))) (defmacro with-input-from-mime-body-stream ((stream part &key (binary t)) &body forms) `(with-open-stream (,stream (mime-body-stream ,part :binary ,binary)) @@ -214,12 +214,12 @@ (defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part)) (and (call-next-method) (with-input-from-mime-body-stream (in1 part1) - (with-input-from-mime-body-stream (in2 part2) - (loop - for b1 = (read-byte in1 nil) - for b2 = (read-byte in2 nil) - always (eq b1 b2) - while (and b1 b2)))))) + (with-input-from-mime-body-stream (in2 part2) + (loop + for b1 = (read-byte in1 nil) + for b2 = (read-byte in2 nil) + always (eq b1 b2) + while (and b1 b2)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -238,7 +238,7 @@ (aif (assoc name (mime-type-parameters part) :test #'string-equal) (setf (cdr it) value) (push (cons name value) - (mime-type-parameters part))) + (mime-type-parameters part))) value) (defgeneric get-mime-disposition-parameter (part name) @@ -252,7 +252,7 @@ (aif (assoc name (mime-disposition-parameters part) :test #'string-equal) (setf (cdr it) value) (push (cons name value) - (mime-disposition-parameters part)))) + (mime-disposition-parameters part)))) (defmethod mime-part-file-name ((part mime-part)) "Return the filename associated to mime PART or NIL if the mime @@ -263,7 +263,7 @@ part doesn't have a file name." (defmethod (setf mime-part-file-name) (value (part mime-part)) "Set the filename associated to mime PART." (setf (get-mime-disposition-parameter part :filename) value - (get-mime-type-parameter part :name) value)) + (get-mime-type-parameter part :name) value)) (defun mime-text-charset (part) (get-mime-type-parameter part :charset)) @@ -272,31 +272,31 @@ part doesn't have a file name." "Split parts of a MIME headers. These are divided by semi-colons not within strings or comments." (labels ((skip-comment (pos) - (loop - while (< pos (length string)) - do (case (elt string pos) - (#\( (setf pos (skip-comment (1+ pos)))) - (#\\ (incf pos 2)) - (#\) (return (1+ pos))) - (otherwise (incf pos))) - finally (return pos))) - (skip-string (pos) - (loop - while (< pos (length string)) - do (case (elt string pos) - (#\\ (incf pos 2)) - (#\" (return (1+ pos))) - (otherwise (incf pos))) - finally (return pos)))) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\( (setf pos (skip-comment (1+ pos)))) + (#\\ (incf pos 2)) + (#\) (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos))) + (skip-string (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\\ (incf pos 2)) + (#\" (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos)))) (loop with start = 0 and i = 0 and parts = '() while (< i (length string)) do (case (elt string i) - (#\; (push (subseq string start i) parts) - (setf start (incf i))) - (#\" (setf i (skip-string i))) - (#\( (setf i (skip-comment (1+ i)))) - (otherwise (incf i))) + (#\; (push (subseq string start i) parts) + (setf start (incf i))) + (#\" (setf i (skip-string i))) + (#\( (setf i (skip-comment (1+ i)))) + (otherwise (incf i))) finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts))))))) (defun parse-parameter (string) @@ -305,20 +305,20 @@ semi-colons not within strings or comments." (be equal-position (position #\= string) (when equal-position (be key (subseq string 0 equal-position) - (if (= equal-position (1- (length string))) - (cons key "") - (be value (string-trim-whitespace (subseq string (1+ equal-position))) - (cons key - (if (and (> (length value) 1) - (char= #\" (elt value 0))) - ;; the syntax of a RFC822 string is more or - ;; less the same as the Lisp one: use the Lisp - ;; reader - (or (ignore-errors (read-from-string value)) - (subseq value 1)) - (be end (or (position-if #'whitespace-p value) - (length value)) - (subseq value 0 end)))))))))) + (if (= equal-position (1- (length string))) + (cons key "") + (be value (string-trim-whitespace (subseq string (1+ equal-position))) + (cons key + (if (and (> (length value) 1) + (char= #\" (elt value 0))) + ;; the syntax of a RFC822 string is more or + ;; less the same as the Lisp one: use the Lisp + ;; reader + (or (ignore-errors (read-from-string value)) + (subseq value 1)) + (be end (or (position-if #'whitespace-p value) + (length value)) + (subseq value 0 end)))))))))) (defun parse-content-type (string) "Parse string as a Content-Type MIME header and return a list @@ -326,14 +326,14 @@ of three elements. The first is the type, the second is the subtype and the third is an alist of parameters and their values. Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." (let* ((parts (split-header-parts string)) - (content-type-string (car parts)) - (slash (position #\/ content-type-string))) + (content-type-string (car parts)) + (slash (position #\/ content-type-string))) ;; You'd be amazed to know how many MUA can't produce an RFC ;; compliant message. (when slash (let ((type (subseq content-type-string 0 slash)) - (subtype (subseq content-type-string (1+ slash)))) - (list type subtype (remove nil (mapcar #'parse-parameter (cdr parts)))))))) + (subtype (subseq content-type-string (1+ slash)))) + (list type subtype (remove nil (mapcar #'parse-parameter (cdr parts)))))))) (defun parse-content-disposition (string) "Parse string as a Content-Disposition MIME header and return a @@ -342,9 +342,9 @@ the optional parameters alist. Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." (be parts (split-header-parts string) (cons (car parts) (mapcan #'(lambda (parameter-string) - (awhen (parse-parameter parameter-string) - (list it))) - (cdr parts))))) + (awhen (parse-parameter parameter-string) + (list it))) + (cdr parts))))) (defun parse-RFC822-header (string) "Parse STRING which should be a valid RFC822 message header and @@ -353,7 +353,7 @@ the header value." (be colon (position #\: string) (when colon (values (string-trim-whitespace (subseq string 0 colon)) - (string-trim-whitespace (subseq string (1+ colon))))))) + (string-trim-whitespace (subseq string (1+ colon))))))) (defvar *default-type* '("text" "plain" (("charset" . "us-ascii"))) @@ -384,40 +384,40 @@ quote messages, for instance.")) "Read through BODY-STREAM. Call CONTENTS-FUNCTION at each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." (let* ((boundary (s+ "--" part-boundary)) - (boundary-length (length boundary))) + (boundary-length (length boundary))) (labels ((output-line (line) - (funcall contents-function line)) - (end-part () - (funcall end-part-function)) - (last-part () - (end-part) - (return-from do-multipart-parts)) - (process-line (line) - (cond ((not (string-starts-with boundary line)) - ;; normal line - (output-line line)) - ((and (= (length (string-trim-whitespace line)) - (+ 2 boundary-length)) - (string= "--" line :start2 boundary-length)) - ;; end of the last part - (last-part)) - ;; according to RFC2046 "the boundary may be followed - ;; by zero or more characters of linear whitespace" - ((= (length (string-trim-whitespace line)) boundary-length) - ;; beginning of the next part - (end-part)) - (t - ;; the line boundary is followed by some - ;; garbage; we treat it as a normal line - (output-line line))))) + (funcall contents-function line)) + (end-part () + (funcall end-part-function)) + (last-part () + (end-part) + (return-from do-multipart-parts)) + (process-line (line) + (cond ((not (string-starts-with boundary line)) + ;; normal line + (output-line line)) + ((and (= (length (string-trim-whitespace line)) + (+ 2 boundary-length)) + (string= "--" line :start2 boundary-length)) + ;; end of the last part + (last-part)) + ;; according to RFC2046 "the boundary may be followed + ;; by zero or more characters of linear whitespace" + ((= (length (string-trim-whitespace line)) boundary-length) + ;; beginning of the next part + (end-part)) + (t + ;; the line boundary is followed by some + ;; garbage; we treat it as a normal line + (output-line line))))) (loop - for line = (read-line body-stream nil) - ;; we should never reach the end of a proper multipart MIME - ;; stream, but we don't want to be fooled by corrupted ones, - ;; so we check for EOF - unless line - do (last-part) - do (process-line line))))) + for line = (read-line body-stream nil) + ;; we should never reach the end of a proper multipart MIME + ;; stream, but we don't want to be fooled by corrupted ones, + ;; so we check for EOF + unless line + do (last-part) + do (process-line line))))) ;; This awkward handling of newlines is due to RFC2046: "The CRLF ;; preceding the boundary delimiter line is conceptually attached to @@ -431,16 +431,16 @@ each (non-boundary) line or END-PART-FUNCTION at each 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)) + (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))) + (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 @@ -451,20 +451,20 @@ PART-BOUNDARY. Return a list of strings." "Read from BODY-STREAM and return the file offset of the MIME parts separated by PART-BOUNDARY." (let ((parts '()) - (start 0) - (len 0) - (beginning-of-part-p t)) + (start 0) + (len 0) + (beginning-of-part-p t)) (flet ((sum-chars (line) - (incf len (length line)) - ;; account for the #\newline - (if beginning-of-part-p - (setf beginning-of-part-p nil) - (incf len))) - (end-part () - (setf beginning-of-part-p t) - (push (cons start (+ start len)) parts) - (setf start (file-position body-stream) - len 0))) + (incf len (length line)) + ;; account for the #\newline + (if beginning-of-part-p + (setf beginning-of-part-p nil) + (incf len))) + (end-part () + (setf beginning-of-part-p t) + (push (cons start (+ start len)) parts) + (setf start (file-position body-stream) + len 0))) (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part) ;; the first part is all the stuff up to the first boundary; ;; just junk @@ -479,19 +479,19 @@ separated by PART-BOUNDARY." (when (mime-version part) (format stream "~&MIME-Version: ~A~%" (mime-version part))) (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part) - (mapcar #'(lambda (pair) - (list (car pair) (cdr pair))) - (mime-type-parameters part))) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-type-parameters part))) (awhen (mime-encoding part) (format stream "Content-Transfer-Encoding: ~A~%" it)) (awhen (mime-description part) (format stream "Content-Description: ~A~%" it)) (when (mime-disposition part) (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%" - (mime-disposition part) - (mapcar #'(lambda (pair) - (list (car pair) (cdr pair))) - (mime-disposition-parameters part)))) + (mime-disposition part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-disposition-parameters part)))) (awhen (mime-id part) (format stream "Content-ID: ~A~%" it)) (terpri stream)) @@ -505,19 +505,19 @@ separated by PART-BOUNDARY." (dolist (h (mime-message-headers part)) (unless (stringp (car h)) (setf (car h) - (string-capitalize (car h)))) + (string-capitalize (car h)))) (unless (or (string-starts-with "content-" (car h) #'string-equal) - (string-equal "mime-version" (car h))) + (string-equal "mime-version" (car h))) (format stream "~A: ~A~%" - (car h) (cdr h)))) + (car h) (cdr h)))) (encode-mime-part (mime-body part) stream)) (defmethod encode-mime-part ((part mime-multipart) stream) ;; choose a boundary if not already set (let* ((original-boundary (get-mime-type-parameter part :boundary)) - (boundary (choose-boundary (mime-parts part) original-boundary))) + (boundary (choose-boundary (mime-parts part) original-boundary))) (unless (and original-boundary - (string= boundary original-boundary)) + (string= boundary original-boundary)) (setf (get-mime-type-parameter part :boundary) boundary)) (call-next-method))) @@ -532,8 +532,8 @@ separated by PART-BOUNDARY." (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)))) + (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)) @@ -547,9 +547,9 @@ the RFC822." (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch) (declare (ignore dst)) (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D" - (subseq (week-day->string week-day) 0 3) - day (subseq (month->string month) 0 3) (mod year 100) hh mm ss - (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60)))) + (subseq (week-day->string week-day) 0 3) + day (subseq (month->string month) 0 3) (mod year 100) hh mm ss + (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60)))) (defun parse-RFC822-date (date-string) "Parse a RFC822 compliant date string and return an universal @@ -560,24 +560,24 @@ time." (awhen (position #\, date-string) (setf date-string (subseq date-string (1+ it)))) (destructuring-bind (day month year time &optional tz &rest rubbish) - (split-at '(#\space #\tab) date-string) + (split-at '(#\space #\tab) date-string) (declare (ignore rubbish)) (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:) - (encode-universal-time - (if ss - (read-from-string ss) - 0) - (read-from-string mm) - (read-from-string hh) - (read-from-string day) - (1+ (position month - '("Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") - :test #'string-equal)) - (read-from-string year) - (when (and tz (or (char= #\+ (elt tz 0)) - (char= #\- (elt tz 0)))) - (/ (read-from-string tz) 100))))))) + (encode-universal-time + (if ss + (read-from-string ss) + 0) + (read-from-string mm) + (read-from-string hh) + (read-from-string day) + (1+ (position month + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :test #'string-equal)) + (read-from-string year) + (when (and tz (or (char= #\+ (elt tz 0)) + (char= #\- (elt tz 0)))) + (/ (read-from-string tz) 100))))))) (defun read-RFC822-headers (stream &optional required-headers) "Read RFC822 compliant headers from STREAM and return them in a @@ -589,29 +589,29 @@ found in STREAM." (loop with headers = '() and skip-header = nil for line = (be line (read-line stream nil) - ;; skip the Unix "From " header if present - (if (string-starts-with "From " line) - (read-line stream nil) - line)) + ;; skip the Unix "From " header if present + (if (string-starts-with "From " line) + (read-line stream nil) + line)) then (read-line stream nil) while (and line - (not (zerop (length line)))) + (not (zerop (length line)))) do (if (whitespace-p (elt line 0)) - (unless (or skip-header - (null headers)) - (setf (cdar headers) (s+ (cdar headers) '(#\newline) line))) - (multiple-value-bind (name value) (parse-RFC822-header line) - ;; the line contained rubbish instead of an header: we - ;; play nice and return as we were at the end of the - ;; headers - (unless name - (return (nreverse headers))) - (if (or (null required-headers) - (member name required-headers :test #'string-equal)) - (progn - (push (cons name value) headers) - (setf skip-header nil)) - (setf skip-header t)))) + (unless (or skip-header + (null headers)) + (setf (cdar headers) (s+ (cdar headers) '(#\newline) line))) + (multiple-value-bind (name value) (parse-RFC822-header line) + ;; the line contained rubbish instead of an header: we + ;; play nice and return as we were at the end of the + ;; headers + (unless name + (return (nreverse headers))) + (if (or (null required-headers) + (member name required-headers :test #'string-equal)) + (progn + (push (cons name value) headers) + (setf skip-header nil)) + (setf skip-header t)))) finally (return (nreverse headers)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -631,35 +631,35 @@ found in 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))) + (make-file-portion :data (etypecase base + (my-string-input-stream + (stream-string base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (file-position stream) + :end (stream-end stream))) (call-next-method)))) (defmethod decode-mime-body ((part mime-part) (stream file-stream)) (if *lazy-mime-decode* (setf (mime-body part) - (make-file-portion :data (pathname stream) - :encoding (mime-encoding part) - :start (file-position stream))) + (make-file-portion :data (pathname stream) + :encoding (mime-encoding part) + :start (file-position stream))) (call-next-method))) (defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream)) (if *lazy-mime-decode* (setf (mime-body part) - (make-file-portion :data (stream-string stream) - :encoding (mime-encoding part) - :start (file-position stream))) + (make-file-portion :data (stream-string stream) + :encoding (mime-encoding part) + :start (file-position stream))) (call-next-method))) (defmethod decode-mime-body ((part mime-part) stream) (setf (mime-body part) - (decode-stream-to-sequence stream (mime-encoding part)))) + (decode-stream-to-sequence stream (mime-encoding part)))) (defmethod decode-mime-body ((part mime-multipart) stream) "Decode STREAM according to PART characteristics and return a @@ -667,24 +667,24 @@ list of MIME parts." (save-file-excursion (stream) (be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary)) (setf (mime-parts part) - (mapcar #'(lambda (p) - (destructuring-bind (start . end) p - (be *default-type* (if (eq :digest (mime-subtype part)) - '("message" "rfc822" ()) - '("text" "plain" (("charset" . "us-ascii")))) - in (make-instance 'delimited-input-stream - :stream stream - :dont-close t - :start start - :end end) - (read-mime-part in)))) - offsets))))) + (mapcar #'(lambda (p) + (destructuring-bind (start . end) p + (be *default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii")))) + in (make-instance 'delimited-input-stream + :stream stream + :dont-close t + :start start + :end end) + (read-mime-part in)))) + offsets))))) (defmethod decode-mime-body ((part mime-message) stream) "Read from STREAM the body of PART. Return the decoded MIME body." (setf (mime-body part) - (read-mime-message stream))) + (read-mime-message stream))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -713,37 +713,37 @@ Return STRING itself if STRING is an unkown encoding." has to be read from STREAM. If the mime part type can't be guessed from the headers, use the *DEFAULT-TYPE*." (flet ((hdr (what) - (header what headers))) + (header what headers))) (destructuring-bind (type subtype parms) - (or - (aand (hdr :content-type) - (parse-content-type it)) - *default-type*) + (or + (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal)) - 'mime-unknown-part)) - (disp (aif (hdr :content-disposition) - (parse-content-disposition it) - (values nil nil))) - (part (make-instance class - :type (hdr :content-type) - :subtype subtype - :type-parameters parms - :disposition (car disp) - :disposition-parameters (cdr disp) - :mime-version (hdr :mime-version) - :encoding (keywordify-encoding - (hdr :content-transfer-encoding)) - :description (hdr :content-description) - :id (hdr :content-id) - :allow-other-keys t))) - (decode-mime-body part stream) - part)))) + 'mime-unknown-part)) + (disp (aif (hdr :content-disposition) + (parse-content-disposition it) + (values nil nil))) + (part (make-instance class + :type (hdr :content-type) + :subtype subtype + :type-parameters parms + :disposition (car disp) + :disposition-parameters (cdr disp) + :mime-version (hdr :mime-version) + :encoding (keywordify-encoding + (hdr :content-transfer-encoding)) + :description (hdr :content-description) + :id (hdr :content-id) + :allow-other-keys t))) + (decode-mime-body part stream) + part)))) (defun read-mime-part (stream) "Read mime part from STREAM. Return a MIME-PART object." (be headers (read-rfc822-headers stream - '(:mime-version :content-transfer-encoding :content-type - :content-disposition :content-description :content-id)) + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)) (make-mime-part headers stream))) (defun read-mime-message (stream) @@ -752,17 +752,17 @@ returns a MIME-MESSAGE object." (be headers (read-rfc822-headers stream) *default-type* '("text" "plain" (("charset" . "us-ascii"))) (flet ((hdr (what) - (header what headers))) + (header what headers))) (destructuring-bind (type subtype parms) - (or (aand (hdr :content-type) - (parse-content-type it)) - *default-type*) - (declare (ignore type subtype)) - (make-instance 'mime-message - :headers headers - ;; this is just for easy access - :type-parameters parms - :body (make-mime-part headers stream)))))) + (or (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (declare (ignore type subtype)) + (make-instance 'mime-message + :headers headers + ;; this is just for easy access + :type-parameters parms + :body (make-mime-part headers stream)))))) (defmethod mime-message ((msg mime-message)) msg) @@ -776,7 +776,7 @@ returns a MIME-MESSAGE object." (defmethod mime-message ((msg pathname)) (let (#+sbcl(sb-impl::*default-external-format* :latin-1) - #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) + #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) (with-open-file (in msg) (read-mime-message in)))) @@ -791,9 +791,9 @@ returns a MIME-MESSAGE object." (defmethod mime-part ((object pathname)) (make-instance 'mime-application - :subtype "octect-stream" - :content-transfer-encoding :base64 - :body (read-file object :element-type '(unsigned-byte 8)))) + :subtype "octect-stream" + :content-transfer-encoding :base64 + :body (read-file object :element-type '(unsigned-byte 8)))) (defmethod mime-part ((object mime-part)) object) @@ -803,39 +803,39 @@ returns a MIME-MESSAGE object." (defmethod make-encoded-body-stream ((part mime-bodily-part)) (be body (mime-body part) (make-instance (case (mime-encoding part) - (:base64 - 'base64-encoder-input-stream) - (:quoted-printable - 'quoted-printable-encoder-input-stream) - (t - '8bit-encoder-input-stream)) - :stream (make-instance 'binary-input-adapter-stream :source body)))) + (:base64 + 'base64-encoder-input-stream) + (:quoted-printable + 'quoted-printable-encoder-input-stream) + (t + '8bit-encoder-input-stream)) + :stream (make-instance 'binary-input-adapter-stream :source body)))) (defun choose-boundary (parts &optional default) (labels ((match-in-parts (boundary parts) - (loop - for p in parts - thereis (typecase p - (mime-multipart - (match-in-parts boundary (mime-parts p))) - (mime-bodily-part - (match-in-body p boundary))))) - (match-in-body (part boundary) - (with-open-stream (in (make-encoded-body-stream part)) - (loop - for line = (read-line in nil) - while line - when (string= line boundary) - return t - finally (return nil))))) + (loop + for p in parts + thereis (typecase p + (mime-multipart + (match-in-parts boundary (mime-parts p))) + (mime-bodily-part + (match-in-body p boundary))))) + (match-in-body (part boundary) + (with-open-stream (in (make-encoded-body-stream part)) + (loop + for line = (read-line in nil) + while line + when (string= line boundary) + return t + finally (return nil))))) (do ((boundary (if default - (format nil "--~A" default) - #1=(format nil "--~{~36R~}" - (loop - for i from 0 below 20 - collect (random 36)))) - #1#)) - ((not (match-in-parts boundary parts)) (subseq boundary 2))))) + (format nil "--~A" default) + #1=(format nil "--~{~36R~}" + (loop + for i from 0 below 20 + collect (random 36)))) + #1#)) + ((not (match-in-parts boundary parts)) (subseq boundary 2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -870,10 +870,10 @@ returns a MIME-MESSAGE object." ;; try to choose something simple to print or the first thing (be parts (mime-parts part) (print-mime-part (or (find-if #'(lambda (part) - (and (eq (class-of part) (find-class 'mime-text)) - (eq (mime-subtype part) :plain))) - parts) - (car parts)) out))) + (and (eq (class-of part) (find-class 'mime-text)) + (eq (mime-subtype part) :plain))) + parts) + (car parts)) out))) (otherwise (dolist (subpart (mime-parts part)) (print-mime-part subpart out))))) @@ -888,29 +888,29 @@ returns a MIME-MESSAGE object." (write-string body out)) (vector (loop - for byte across body - do (write-char (code-char byte) out))) + for byte across body + do (write-char (code-char byte) out))) (pathname (with-open-file (in body) - (loop - for c = (read-char in nil) - while c - do (write-char c out))))))) + (loop + for c = (read-char in nil) + while c + do (write-char c out))))))) (defmethod print-mime-part ((part mime-message) (out stream)) (flet ((hdr (name) - (multiple-value-bind (value tag) - (header name (mime-message-headers part)) - (cons tag value)))) + (multiple-value-bind (value tag) + (header name (mime-message-headers part)) + (cons tag value)))) (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id"))) (when h - (format out "~&~A: ~A" (car h) (cdr h)))) + (format out "~&~A: ~A" (car h) (cdr h)))) (format out "~2%") (print-mime-part (mime-body part) out))) (defmethod print-mime-part ((part mime-part) (out stream)) (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%" - (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part))) + (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -929,19 +929,19 @@ second in MIME.")) (if (null path) part (if (= 1 (car path)) - (find-mime-part-by-path (mime-body part) (cdr path)) - (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)." - part (car path))))) + (find-mime-part-by-path (mime-body part) (cdr path)) + (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)." + part (car path))))) (defmethod find-mime-part-by-path ((part mime-multipart) path) (if (null path) part (be parts (mime-parts part) - part-number (car path) - (if (<= 1 part-number (length parts)) - (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path)) - (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)." - part (length parts) part-number))))) + part-number (car path) + (if (<= 1 part-number (length parts)) + (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path)) + (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)." + part (length parts) part-number))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -960,8 +960,8 @@ is a string.")) (defmethod find-mime-part-by-id ((part mime-multipart) id) (or (call-next-method) (some #'(lambda (p) - (find-mime-part-by-id p id)) - (mime-parts part)))) + (find-mime-part-by-id p id)) + (mime-parts part)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1038,8 +1038,8 @@ is a string.")) (defmethod map-parts ((function function) (part mime-multipart)) (setf (mime-parts part) (mapcar #'(lambda (p) - (map-parts function p)) - (mime-parts part))) + (map-parts function p)) + (mime-parts part))) part) ;; apply-on-parts is like map-parts but doesn't modify the parts (at least diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd index e4d983c057..cd6bca2361 100644 --- a/third_party/lisp/mime4cl/mime4cl-tests.asd +++ b/third_party/lisp/mime4cl/mime4cl-tests.asd @@ -24,7 +24,7 @@ (defpackage :mime4cl-tests-system (:use :common-lisp :asdf #+asdfa :asdfa) (:export #:*base-directory* - #:*compilation-epoch*)) + #:*compilation-epoch*)) (in-package :mime4cl-tests-system) @@ -39,12 +39,12 @@ :depends-on (:mime4cl) :components ((:module test - :components - ((:file "rt") - (:file "package" :depends-on ("rt")) - (:file "endec" :depends-on ("rt" "package")) - (:file "address" :depends-on ("rt" "package")) - (:file "mime" :depends-on ("rt" "package")))))) + :components + ((:file "rt") + (:file "package" :depends-on ("rt")) + (:file "endec" :depends-on ("rt" "package")) + (:file "address" :depends-on ("rt" "package")) + (:file "mime" :depends-on ("rt" "package")))))) ;; when loading this form the regression-test, the package is yet to ;; be loaded so we cannot use rt:do-tests directly or we would get a diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp index a6e7e7d8ef..fc5d9627f9 100644 --- a/third_party/lisp/mime4cl/package.lisp +++ b/third_party/lisp/mime4cl/package.lisp @@ -23,86 +23,86 @@ (defpackage :mime4cl (:nicknames :mime) (:use :common-lisp :npg :sclf - ;; for Gray streams - #+cmu :extensions #+sbcl :sb-gray) + ;; for Gray streams + #+cmu :extensions #+sbcl :sb-gray) ;; this is stuff that comes from SCLF and clashes with CMUCL's EXT ;; package (:shadowing-import-from :sclf - #:process-wait - #:process-alive-p - #:run-program) + #:process-wait + #:process-alive-p + #:run-program) (:export #:*lazy-mime-decode* - #:print-mime-part - #:read-mime-message - #:mime-part - #:mime-text - #:mime-binary - #:mime-id - #:mime-image - #:mime-message - #:mime-multipart - #:mime-audio - #:mime-unknown-part - #:get-mime-disposition-parameter - #:get-mime-type-parameter - #:mime-disposition - #:mime-disposition-parameters - #:mime-encoding - #:mime-application - #:mime-video - #:mime-description - #:mime-part-size - #:mime-subtype - #:mime-body - #:mime-body-stream - #:mime-body-length - #:mime-parts - #:mime-part-p - #:mime-type - #:mime-type-string - #:mime-type-parameters - #:mime-message-headers - #:mime= - #:find-mime-part-by-path - #:find-mime-part-by-id - #:find-mime-text-part - #:encode-mime-part - #:encode-mime-body - #:decode-quoted-printable-stream - #:decode-quoted-printable-string - #:encode-quoted-printable-stream - #:encode-quoted-printable-sequence - #:decode-base64-stream - #:decode-base64-string - #:encode-base64-stream - #:encode-base64-sequence - #:parse-RFC2047-text - #:parse-RFC822-header - #:read-RFC822-headers - #:time-RFC822-string - #:parse-RFC822-date - #:map-parts - #:do-parts - #:apply-on-parts - #:mime-part-file-name - #:mime-text-charset - #:with-input-from-mime-body-stream - ;; endec.lisp - #:base64-encoder - #:base64-decoder - #:null-encoder - #:null-decoder - #:byte-encoder - #:byte-decoder - #:quoted-printable-encoder - #:quoted-printable-decoder - #:encoder-write-byte - #:encoder-finish-output - #:decoder-read-byte - #:decoder-read-sequence - #:*base64-line-length* - #:*quoted-printable-line-length* - ;; address.lisp - #:parse-addresses #:mailboxes-only - #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address - #:mailbox-group #:mbxg-name #:mbxg-mailboxes)) + #:print-mime-part + #:read-mime-message + #:mime-part + #:mime-text + #:mime-binary + #:mime-id + #:mime-image + #:mime-message + #:mime-multipart + #:mime-audio + #:mime-unknown-part + #:get-mime-disposition-parameter + #:get-mime-type-parameter + #:mime-disposition + #:mime-disposition-parameters + #:mime-encoding + #:mime-application + #:mime-video + #:mime-description + #:mime-part-size + #:mime-subtype + #:mime-body + #:mime-body-stream + #:mime-body-length + #:mime-parts + #:mime-part-p + #:mime-type + #:mime-type-string + #:mime-type-parameters + #:mime-message-headers + #:mime= + #:find-mime-part-by-path + #:find-mime-part-by-id + #:find-mime-text-part + #:encode-mime-part + #:encode-mime-body + #:decode-quoted-printable-stream + #:decode-quoted-printable-string + #:encode-quoted-printable-stream + #:encode-quoted-printable-sequence + #:decode-base64-stream + #:decode-base64-string + #:encode-base64-stream + #:encode-base64-sequence + #:parse-RFC2047-text + #:parse-RFC822-header + #:read-RFC822-headers + #:time-RFC822-string + #:parse-RFC822-date + #:map-parts + #:do-parts + #:apply-on-parts + #:mime-part-file-name + #:mime-text-charset + #:with-input-from-mime-body-stream + ;; endec.lisp + #:base64-encoder + #:base64-decoder + #:null-encoder + #:null-decoder + #:byte-encoder + #:byte-decoder + #:quoted-printable-encoder + #:quoted-printable-decoder + #:encoder-write-byte + #:encoder-finish-output + #:decoder-read-byte + #:decoder-read-sequence + #:*base64-line-length* + #:*quoted-printable-line-length* + ;; address.lisp + #:parse-addresses #:mailboxes-only + #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address + #:mailbox-group #:mbxg-name #:mbxg-mailboxes)) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp index 64c7adeec5..087207ce53 100644 --- a/third_party/lisp/mime4cl/streams.lisp +++ b/third_party/lisp/mime4cl/streams.lisp @@ -32,36 +32,36 @@ (stream-file-position stream position)) (defvar *original-file-position-function* (prog1 - (symbol-function 'file-position) + (symbol-function 'file-position) (setf (symbol-function 'file-position) (symbol-function 'my-file-position)))) (defmethod stream-file-position (stream &optional position) (if position - (funcall *original-file-position-function* stream position) - (funcall *original-file-position-function* stream))) + (funcall *original-file-position-function* stream position) + (funcall *original-file-position-function* stream))) ;; oddly CMUCL doesn't seem to provide a default for STREAM-READ-SEQUENCE (defmacro make-read-sequence (stream-type element-reader) `(defmethod stream-read-sequence ((stream ,stream-type) seq &optional start end) (unless start - (setf start 0)) + (setf start 0)) (unless end - (setf end (length seq))) + (setf end (length seq))) (loop - for i from start below end - for b = (,element-reader stream) - until (eq b :eof) - do (setf (elt seq i) b) - finally (return i)))) + for i from start below end + for b = (,element-reader stream) + until (eq b :eof) + do (setf (elt seq i) b) + finally (return i)))) (make-read-sequence fundamental-binary-input-stream stream-read-byte) (make-read-sequence fundamental-character-input-stream stream-read-char)) (defclass coder-stream-mixin () ((real-stream :type stream - :initarg :stream - :reader real-stream) + :initarg :stream + :reader real-stream) (dont-close :initform nil - :initarg :dont-close))) + :initarg :dont-close))) (defmethod stream-file-position ((stream coder-stream-mixin) &optional position) (apply #'file-position (remove nil (list (slot-value stream 'real-stream) @@ -91,15 +91,15 @@ (call-next-method) (unless (slot-boundp stream 'output-function) (setf (slot-value stream 'output-function) - #'(lambda (char) - (write-char char (slot-value stream 'real-stream)))))) + #'(lambda (char) + (write-char char (slot-value stream 'real-stream)))))) (defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys) (call-next-method) (unless (slot-boundp stream 'input-function) (setf (slot-value stream 'input-function) - #'(lambda () - (read-char (slot-value stream 'real-stream) nil))))) + #'(lambda () + (read-char (slot-value stream 'real-stream) nil))))) (defmethod stream-read-byte ((stream coder-input-stream-mixin)) (or (decoder-read-byte stream) @@ -136,36 +136,36 @@ in a stream of character.")) (call-next-method) (with-slots (encoder buffer-queue) stream (setf encoder - (make-instance 'quoted-printable-encoder - :output-function #'(lambda (char) - (queue-append buffer-queue char)))))) + (make-instance 'quoted-printable-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) (defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys) (call-next-method) (with-slots (encoder buffer-queue) stream (setf encoder - (make-instance 'base64-encoder - :output-function #'(lambda (char) - (queue-append buffer-queue char)))))) + (make-instance 'base64-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) (defmethod stream-read-char ((stream encoder-input-stream)) (with-slots (encoder buffer-queue real-stream) stream (loop while (queue-empty-p buffer-queue) do (be byte (read-byte real-stream nil) - (if byte - (encoder-write-byte encoder byte) - (progn - (encoder-finish-output encoder) - (queue-append buffer-queue :eof))))) + (if byte + (encoder-write-byte encoder byte) + (progn + (encoder-finish-output encoder) + (queue-append buffer-queue :eof))))) (queue-pop buffer-queue))) (defmethod stream-read-char ((stream 8bit-encoder-input-stream)) (with-slots (real-stream) stream (aif (read-byte real-stream nil) - (code-char it) - :eof))) + (code-char it) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -192,31 +192,31 @@ in a stream of character.")) (etypecase source (string (setf real-stream (make-string-input-stream source) - input-function #'(lambda () - (awhen (read-char real-stream nil) - (char-code it))))) + 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))))))) + (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))))) + #'(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)))) + 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))))))) + input-function #'(lambda () + (read-byte real-stream nil))))))) (defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys) (call-next-method) @@ -225,31 +225,31 @@ in a stream of character.")) (etypecase source (string (setf real-stream (make-string-input-stream source) - input-function #'(lambda () - (read-char real-stream nil)))) + 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))))))) + (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)))))) + #'(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)))) + 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)))))))) + 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) @@ -259,31 +259,31 @@ in a stream of character.")) (defmethod stream-read-byte ((stream binary-input-adapter-stream)) (with-slots (input-function) stream (or (funcall input-function) - :eof))) + :eof))) (defmethod stream-read-char ((stream character-input-adapter-stream)) (with-slots (input-function) stream (or (funcall input-function) - :eof))) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin) ((start-offset :initarg :start - :initform 0 - :reader stream-start - :type integer) + :initform 0 + :reader stream-start + :type integer) (end-offset :initarg :end - :initform nil - :reader stream-end - :type (or null integer)))) + :initform nil + :reader stream-end + :type (or null integer)))) (defmethod print-object ((object delimited-input-stream) stream) (if *print-readably* (call-next-method) (with-slots (start-offset end-offset) object - (print-unreadable-object (object stream :type t :identity t) - (format stream "start=~A end=~A" start-offset end-offset))))) + (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) @@ -301,24 +301,24 @@ in a stream of character.")) (defmethod stream-read-char ((stream delimited-input-stream)) (with-slots (real-stream end-offset) stream (if (or (not end-offset) - (< (file-position real-stream) end-offset)) - (or (read-char real-stream nil) - :eof) - :eof))) + (< (file-position real-stream) end-offset)) + (or (read-char real-stream nil) + :eof) + :eof))) #+(OR)(defmethod stream-read-byte ((stream delimited-input-stream)) (with-slots (real-stream end-offset) stream (if (or (not end-offset) - (< (file-position real-stream) end-offset)) - (or (read-byte real-stream nil) - :eof) - :eof))) + (< (file-position real-stream) end-offset)) + (or (read-byte real-stream nil) + :eof) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin) ((string :initarg :string - :reader stream-string))) + :reader stream-string))) (defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys) (call-next-method) @@ -329,7 +329,7 @@ in a stream of character.")) (defmethod stream-read-char ((stream my-string-input-stream)) (with-slots (real-stream) stream (or (read-char real-stream nil) - :eof))) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -344,25 +344,25 @@ in a stream of character.")) (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)))) + (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-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)))))) + :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))) + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'base64-decoder-stream) + (t '8bit-decoder-stream)) + :stream (open-file-portion file-portion))) diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp index 7b6763c990..86d358a50c 100644 --- a/third_party/lisp/mime4cl/test/endec.lisp +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -24,66 +24,66 @@ (deftest quoted-printable.1 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "Français, Español, böse, skøl")) + "Français, Español, böse, skøl")) "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l") (deftest quoted-printable.2 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "Français, Español, böse, skøl") - :start 10 :end 17) + "Français, Español, böse, skøl") + :start 10 :end 17) "Espa=F1ol") (deftest quoted-printable.3 (map 'string #'code-char - (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")) + (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")) "Français, Español, böse, skøl") (deftest quoted-printable.4 (map 'string #'code-char - (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l" - :start 12 :end 21)) + (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l" + :start 12 :end 21)) "Español") (deftest quoted-printable.5 (map 'string #'code-char - (decode-quoted-printable-string "this = wrong")) + (decode-quoted-printable-string "this = wrong")) "this = wrong") (deftest quoted-printable.6 (map 'string #'code-char - (decode-quoted-printable-string "this is wrong=")) + (decode-quoted-printable-string "this is wrong=")) "this is wrong=") (deftest quoted-printable.7 (map 'string #'code-char - (decode-quoted-printable-string "this is wrong=1")) + (decode-quoted-printable-string "this is wrong=1")) "this is wrong=1") (deftest quoted-printable.8 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "x = x + 1")) + "x = x + 1")) "x =3D x + 1") (deftest quoted-printable.9 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "x = x + 1 ")) + "x = x + 1 ")) "x =3D x + 1 =20") (deftest quoted-printable.10 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "this string is very very very very very very very very very very very very very very very very very very very very long")) + "this string is very very very very very very very very very very very very very very very very very very very very long")) "this string is very very very very very very very very very very very ve= ry very very very very very very very very long") (deftest quoted-printable.11 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "this string is very very very very long")) + "this string is very very very very long")) "this string is very very = very very long") (deftest quoted-printable.12 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "please read the next + "please read the next line")) "please read the next =20 line") @@ -93,24 +93,24 @@ line") (deftest base64.1 (let ((*base64-line-length* nil)) (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code - "Some random string."))) + "Some random string."))) "U29tZSByYW5kb20gc3RyaW5nLg==") (deftest base64.2 (let ((*base64-line-length* nil)) (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code - "Some random string.") :start 5 :end 11)) + "Some random string.") :start 5 :end 11)) "cmFuZG9t") (deftest base64.3 (map 'string #'code-char - (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) "Some random string.") (deftest base64.4 (map 'string #'code-char - (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" - :start 13 :end 41)) + (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" + :start 13 :end 41)) "Some random string.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -121,47 +121,47 @@ line") (defun perftest-encoder (encoder-class &optional (megs 100)) (declare (optimize (speed 3) (debug 0) (safety 0)) - (type fixnum megs)) + (type fixnum megs)) (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) (let* ((meg (* 1024 1024)) - (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) - (encoder (make-instance encoder-class - :output-function #'(lambda (c) (declare (ignore c)))))) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) (declare (ignore c)))))) (declare (type fixnum meg)) (time (progn - (dotimes (x megs) - (read-sequence buffer in) - (dotimes (i meg) - (mime4cl:encoder-write-byte encoder (aref buffer i)))) - (mime4cl:encoder-finish-output encoder)))))) + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder)))))) (defun perftest-decoder (decoder-class &optional (megs 100)) (declare (optimize (speed 3) (debug 0) (safety 0)) - (type fixnum megs)) + (type fixnum megs)) (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) - :type "encoded-data"))) + :type "encoded-data"))) (sclf:with-temp-file (tmp nil :direction :io) - (let* ((meg (* 1024 1024)) - (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) - (encoder-class (ecase decoder-class - (mime4cl:base64-decoder 'mime4cl:base64-encoder) - (mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder))) - (encoder (make-instance encoder-class - :output-function #'(lambda (c) - (write-char c tmp)))) - (decoder (make-instance decoder-class - :input-function #'(lambda () - (read-char tmp nil))))) - (declare (type fixnum meg)) - (dotimes (x megs) - (read-sequence buffer in) - (dotimes (i meg) - (mime4cl:encoder-write-byte encoder (aref buffer i)))) - (mime4cl:encoder-finish-output encoder) - (file-position tmp 0) - (time - (loop - for b = (mime4cl:decoder-read-byte decoder) - while b))))))) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder-class (ecase decoder-class + (mime4cl:base64-decoder 'mime4cl:base64-encoder) + (mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder))) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) + (write-char c tmp)))) + (decoder (make-instance decoder-class + :input-function #'(lambda () + (read-char tmp nil))))) + (declare (type fixnum meg)) + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder) + (file-position tmp 0) + (time + (loop + for b = (mime4cl:decoder-read-byte decoder) + while b))))))) diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp index 1488f927fc..4d5b104218 100644 --- a/third_party/lisp/mime4cl/test/mime.lisp +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -25,9 +25,9 @@ (defvar *samples-directory* (merge-pathnames (make-pathname :directory '(:relative "samples")) - #.(or *compile-file-pathname* - *load-pathname* - #P""))) + #.(or *compile-file-pathname* + *load-pathname* + #P""))) (defvar *sample1-file* (make-pathname :defaults #.(or *compile-file-pathname* *load-pathname*) @@ -36,21 +36,21 @@ (deftest mime.1 (let* ((orig (mime-message *sample1-file*)) - (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (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")) + :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))) + (format t "~A:~%" f) + (finish-output) + (let* ((orig (mime-message f)) + (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (unless (mime= orig dup) + (return nil))) finally (return t)) t) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp index bde0bf25d5..d3d921e1e4 100644 --- a/third_party/lisp/mime4cl/test/package.lisp +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -24,5 +24,5 @@ (defpackage :mime4cl-tests (:use :common-lisp - :rtest :mime4cl) + :rtest :mime4cl) (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp index d4dd2aedb6..06160debbe 100644 --- a/third_party/lisp/mime4cl/test/rt.lisp +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -23,8 +23,8 @@ (:nicknames #:rtest #-lispworks #:rt) (:use #:cl) (:export #:*do-tests-when-defined* #:*test* #:continue-testing - #:deftest #:do-test #:do-tests #:get-test #:pending-tests - #:rem-all-tests #:rem-test) + #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) (:documentation "The MIT regression tester with pfdietz's modifications")) (in-package :regression-test) @@ -45,7 +45,7 @@ "A list of test names that are expected to fail.") (defstruct (entry (:conc-name nil) - (:type list)) + (:type list)) pend name form) (defmacro vals (entry) `(cdddr ,entry)) @@ -75,12 +75,12 @@ (defun get-entry (name) (let ((entry (find name (cdr *entries*) - :key #'name - :test #'equal))) + :key #'name + :test #'equal))) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." - name)) + name)) entry)) (defmacro deftest (name form &rest values) @@ -93,7 +93,7 @@ (setf (cdr l) (list entry)) (return nil)) (when (equal (name (cadr l)) - (name entry)) + (name entry)) (setf (cadr l) entry) (report-error nil "Redefining test ~:@(~S~)" @@ -105,10 +105,10 @@ (defun report-error (error? &rest args) (cond (*debug* - (apply #'format t args) - (if error? (throw '*debug* nil))) - (error? (apply #'error args)) - (t (apply #'warn args)))) + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) (defun do-test (&optional (name *test*)) (do-entry (get-entry name))) @@ -119,84 +119,84 @@ ((eq x y) t) ((consp x) (and (consp y) - (equalp-with-case (car x) (car y)) - (equalp-with-case (cdr x) (cdr y)))) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) - (= (array-rank x) 0)) + (= (array-rank x) 0)) (equalp-with-case (aref x) (aref y))) ((typep x 'vector) (and (typep y 'vector) - (let ((x-len (length x)) - (y-len (length y))) - (and (eql x-len y-len) - (loop - for e1 across x - for e2 across y - always (equalp-with-case e1 e2)))))) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) ((and (typep x 'array) - (typep y 'array) - (not (equal (array-dimensions x) - (array-dimensions y)))) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) nil) ((typep x 'array) (and (typep y 'array) - (let ((size (array-total-size x))) - (loop for i from 0 below size - always (equalp-with-case (row-major-aref x i) - (row-major-aref y i)))))) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) (t (eql x y)))) (defun do-entry (entry &optional - (s *standard-output*)) + (s *standard-output*)) (catch '*in-test* (setq *test* (name entry)) (setf (pend entry) t) (let* ((*in-test* t) - ;; (*break-on-warnings* t) - (aborted nil) - r) + ;; (*break-on-warnings* t) + (aborted nil) + r) ;; (declare (special *break-on-warnings*)) (block aborted - (setf r - (flet ((%do - () - (if *compile-tests* - (multiple-value-list - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry))))) - (multiple-value-list - (eval (form entry)))))) - (if *catch-errors* - (handler-bind - ((style-warning #'muffle-warning) - (error #'(lambda (c) - (setf aborted t) - (setf r (list c)) - (return-from aborted nil)))) - (%do)) - (%do))))) + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) (setf (pend entry) - (or aborted - (not (equalp-with-case r (vals entry))))) + (or aborted + (not (equalp-with-case r (vals entry))))) (when (pend entry) - (let ((*print-circle* *print-circle-on-failure*)) - (format s "~&Test ~:@(~S~) failed~ + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ ~%Form: ~S~ ~%Expected value~P: ~ ~{~S~^~%~17t~}~%" - *test* (form entry) - (length (vals entry)) - (vals entry)) - (format s "Actual value~P: ~ + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ ~{~S~^~%~15t~}.~%" - (length r) r))))) + (length r) r))))) (when (not (pend entry)) *test*)) (defun continue-testing () @@ -205,50 +205,50 @@ (do-entries *standard-output*))) (defun do-tests (&optional - (out *standard-output*)) + (out *standard-output*)) (dolist (entry (cdr *entries*)) (setf (pend entry) t)) (if (streamp out) (do-entries out) (with-open-file - (stream out :direction :output) - (do-entries stream)))) + (stream out :direction :output) + (do-entries stream)))) (defun do-entries (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" (count t (cdr *entries*) - :key #'pend) - (length (cdr *entries*))) + :key #'pend) + (length (cdr *entries*))) (dolist (entry (cdr *entries*)) (when (pend entry) (format s "~@[~<~%~:; ~:@(~S~)~>~]" - (do-entry entry s)))) + (do-entry entry s)))) (let ((pending (pending-tests)) - (expected-table (make-hash-table :test #'equal))) + (expected-table (make-hash-table :test #'equal))) (dolist (ex *expected-failures*) (setf (gethash ex expected-table) t)) (let ((new-failures - (loop for pend in pending - unless (gethash pend expected-table) - collect pend))) + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) (if (null pending) - (format s "~&No tests failed.") - (progn - (format s "~&~A out of ~A ~ + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ total tests failed: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." - (length pending) - (length (cdr *entries*)) - pending) - (if (null new-failures) - (format s "~&No unexpected failures.") - (when *expected-failures* - (format s "~&~A unexpected failures: ~ + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." - (length new-failures) - new-failures))) - )) + (length new-failures) + new-failures))) + )) (null pending)))) diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp index 68d794ddec..a45ac614f7 100644 --- a/third_party/lisp/npg/examples/python.lisp +++ b/third_party/lisp/npg/examples/python.lisp @@ -38,7 +38,7 @@ (deflazy define-grammar (let ((*package* #.*package*) - (*compile-print* (and parser::*debug* t))) + (*compile-print* (and parser::*debug* t))) (reset-grammar) (format t "~&creating Python grammar...~%") (populate-grammar) @@ -80,8 +80,8 @@ (defrule statement-list := (+ simple-statement ";") :reduce (if (cdr $1) - (cons :statement-list $1) - (car $1))) + (cons :statement-list $1) + (car $1))) (defrule statement := statement-list eol diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp index 2edf1292da..9ebd45a169 100644 --- a/third_party/lisp/npg/examples/vs-cobol-ii.lisp +++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp @@ -38,7 +38,7 @@ (deflazy define-grammar (let ((*package* #.*package*) - (*compile-print* (and parser::*debug* t))) + (*compile-print* (and parser::*debug* t))) (reset-grammar) (format t "creating Cobol grammar...~%") (populate-grammar) @@ -263,8 +263,8 @@ (defrule file-control-entry := select-clause assign-clause fce-phrase* "." :reduce (append select-clause - assign-clause - (flatten-list fce-phrase))) + assign-clause + (flatten-list fce-phrase))) (defrule organization-is := "ORGANIZATION" "IS"?) @@ -658,7 +658,7 @@ (defrule data-description-entry := level-number alt-data-name-filler? data-description-entry-clause* "." :reduce (append (list level-number alt-data-name-filler) - (flatten-list data-description-entry-clause))) + (flatten-list data-description-entry-clause))) (defrule alt-data-name-filler := data-name @@ -754,8 +754,8 @@ (defrule synchronized-clause := synchronized alt-left-right? :reduce `(:synchronized ,(if alt-left-right - alt-left-right - t))) + alt-left-right + t))) (defrule alt-left-right := "LEFT" @@ -1004,7 +1004,7 @@ (defrule compute-statement := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"? :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list)) + :not-on-size-error not-on-size-error-statement-list)) (defrule equal := "=" @@ -1100,12 +1100,12 @@ (defrule if-phrase := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence :reduce (list 'if condition - (if (cdr alt-statement-list-next-sentence) - (cons 'progn alt-statement-list-next-sentence) - (car alt-statement-list-next-sentence)) - (if (cdr alt-statement-list-next-sentence2) - (cons 'progn alt-statement-list-next-sentence2) - (car alt-statement-list-next-sentence2))) + (if (cdr alt-statement-list-next-sentence) + (cons 'progn alt-statement-list-next-sentence) + (car alt-statement-list-next-sentence)) + (if (cdr alt-statement-list-next-sentence2) + (cons 'progn alt-statement-list-next-sentence2) + (car alt-statement-list-next-sentence2))) := "IF" condition "THEN"? alt-statement-list-next-sentence :reduce (append (list 'when condition) alt-statement-list-next-sentence)) @@ -1209,11 +1209,11 @@ (defrule multiply-statement := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list) + :not-on-size-error not-on-size-error-statement-list) := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list)) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) (defrule open-statement := "OPEN" open-statement-phrase+ @@ -1418,17 +1418,17 @@ (defrule subtract-statement := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? :reduce (list 'subtract id-or-lit cobword-rounded - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? :reduce (list 'subtract-corr variable-identifier variable-identifier - :rounded (and $5 t) - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list)) + :rounded (and $5 t) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) (defrule cobword-rounded := variable-identifier "ROUNDED"? @@ -1449,11 +1449,11 @@ (defrule unstring-statement := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"? :reduce (list 'unstring variable-identifier unstring-statement-dst - :delimited-by-all delimited-by-all-phrase - :with-pointer with-pointer-identifier - :tallying tallying-in-identifier - :on-overflow on-overflow-statement-list - :not-on-overflow not-on-overflow-statement-list)) + :delimited-by-all delimited-by-all-phrase + :with-pointer with-pointer-identifier + :tallying tallying-in-identifier + :on-overflow on-overflow-statement-list + :not-on-overflow not-on-overflow-statement-list)) (defrule id-or-lit := literal @@ -1622,8 +1622,8 @@ (defrule combinable-condition := "NOT"? simple-condition :reduce (if $1 - (list 'not simple-condition) - simple-condition)) + (list 'not simple-condition) + simple-condition)) (defrule simple-condition := class-condition @@ -1637,8 +1637,8 @@ (defrule class-condition := variable-identifier "IS"? "NOT"? class-type :reduce (if $3 - (list 'not (list 'type-of variable-identifier (make-keyword class-type))) - (list 'type-of variable-identifier (make-keyword class-type)))) + (list 'not (list 'type-of variable-identifier (make-keyword class-type))) + (list 'type-of variable-identifier (make-keyword class-type)))) (defrule class-type := "NUMERIC" @@ -1651,12 +1651,12 @@ (destructuring-bind (main-operator main-variable other-variable) main-relation (declare (ignore other-variable)) (labels ((unfold (subs) - (if (null subs) - main-relation - (destructuring-bind (connection operator variable) (car subs) - (list connection - (list (or operator main-operator) main-variable variable) - (unfold (cdr subs))))))) + (if (null subs) + main-relation + (destructuring-bind (connection operator variable) (car subs) + (list connection + (list (or operator main-operator) main-variable variable) + (unfold (cdr subs))))))) (unfold subs)))) (defrule relation-condition @@ -1720,8 +1720,8 @@ (defrule sign-condition := arithmetic-expression "IS"? "NOT"? sign-type :reduce (if $3 - `(not (,sign-type ,arithmetic-expression)) - `(,sign-type ,arithmetic-expression))) + `(not (,sign-type ,arithmetic-expression)) + `(,sign-type ,arithmetic-expression))) (defrule sign-type := "POSITIVE" :reduce '> @@ -1743,14 +1743,14 @@ (defrule variable-identifier := qualified-data-name subscript-parentheses* ;; reference-modification? :reduce (if subscript-parentheses - (list :aref qualified-data-name subscript-parentheses) - qualified-data-name)) + (list :aref qualified-data-name subscript-parentheses) + qualified-data-name)) (defrule reference-modification := "(" leftmost-character-position ":" length? ")" :reduce (if length - (list :range leftmost-character-position length) - leftmost-character-position)) + (list :range leftmost-character-position length) + leftmost-character-position)) (defrule condition-name-reference := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*) @@ -1777,8 +1777,8 @@ (defrule qualified-data-name := data-name in-data-or-file-name* :reduce (if in-data-or-file-name - (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. - data-name) + (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. + data-name) := "ADDRESS" "OF" data-name :reduce (list 'address-of data-name) := "LENGTH" "OF" cobol-identifier @@ -1811,8 +1811,8 @@ := plus-or-minus? basis := plus-or-minus? basis "**" power :reduce (if plus-or-minus - `(plus-or-minus (expt basis basis2)) - `(expt basis basis2))) + `(plus-or-minus (expt basis basis2)) + `(expt basis basis2))) (defrule plus-or-minus := "+" diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd index addb7c6932..1e35186d6c 100644 --- a/third_party/lisp/npg/npg.asd +++ b/third_party/lisp/npg/npg.asd @@ -44,12 +44,12 @@ left recursive rules." (:doc-file "COPYING") (:doc-file ".project") (:module :examples - :components - ((:sample-file "python") - (:sample-file "vs-cobol-ii"))) + :components + ((:sample-file "python") + (:sample-file "vs-cobol-ii"))) (:module :src - :components - ((:file "package") - (:file "common" :depends-on ("package")) - (:file "define" :depends-on ("package" "common")) - (:file "parser" :depends-on ("package" "common")))))) + :components + ((:file "package") + (:file "common" :depends-on ("package")) + (:file "define" :depends-on ("package" "common")) + (:file "parser" :depends-on ("package" "common")))))) diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp index f52f0381a2..783f071fc5 100644 --- a/third_party/lisp/npg/src/define.lisp +++ b/third_party/lisp/npg/src/define.lisp @@ -37,13 +37,13 @@ those that are not declared as strings in the grammar.") the list of variables for the function reducing this production, those that are non static and their unambiguous user-friendly names." (flet ((unique (sym list) - (if (not (assoc sym list)) - sym - (loop - for i of-type fixnum from 2 - for x = (intern (format nil "~:@(~A~)~A" sym i)) - while (assoc x list) - finally (return x))))) + (if (not (assoc sym list)) + sym + (loop + for i of-type fixnum from 2 + for x = (intern (format nil "~:@(~A~)~A" sym i)) + while (assoc x list) + finally (return x))))) (loop for tok in tokens for i of-type fixnum from 1 @@ -54,8 +54,8 @@ that are non static and their unambiguous user-friendly names." and when (symbolp tok) collect (list (unique tok named-vars) arg) into named-vars when (and (listp tok) - (symbolp (cadr tok))) - collect (list (unique (cadr tok) named-vars) arg) into named-vars + (symbolp (cadr tok))) + collect (list (unique (cadr tok) named-vars) arg) into named-vars finally (return (values args vars named-vars))))) @@ -63,56 +63,56 @@ that are non static and their unambiguous user-friendly names." "Create a function with name NAME, arguments derived from TOKENS and body ACTION. Return it's definition." (let ((function - (multiple-value-bind (args vars named-vars) - (make-action-arguments tokens) - `(lambda ,args - (declare (ignorable ,@args)) - (let (($vars (list ,@vars)) - ($all (list ,@args)) - ,@named-vars - ($alist (list ,@(mapcar #'(lambda (v) - `(cons ',(intern (symbol-name (car v))) - ,(cadr v))) - named-vars)))) - (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) - (flet ((make-object (&optional type args) - (apply #'make-instance (or type ',name) - (append args $alist)))) - ,action)))))) + (multiple-value-bind (args vars named-vars) + (make-action-arguments tokens) + `(lambda ,args + (declare (ignorable ,@args)) + (let (($vars (list ,@vars)) + ($all (list ,@args)) + ,@named-vars + ($alist (list ,@(mapcar #'(lambda (v) + `(cons ',(intern (symbol-name (car v))) + ,(cadr v))) + named-vars)))) + (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) + (flet ((make-object (&optional type args) + (apply #'make-instance (or type ',name) + (append args $alist)))) + ,action)))))) (when *compile-print* (if *compile-verbose* - (format t "; Compiling ~S:~% ~S~%" name function) - (format t "; Compiling ~S~%" name))) + (format t "; Compiling ~S:~% ~S~%" name function) + (format t "; Compiling ~S~%" name))) (compile name function))) (defun define-rule (name productions) "Accept a rule in EBNF-like syntax, translate it into a sexp and a call to INSERT-RULE-IN-CURRENT-GRAMMAR." (flet ((transform (productions) - (loop - for tok in productions - with prod = nil - with action = nil - with phase = nil - with new-prods = nil - while tok - do (cond ((eq tok :=) - (push (list (nreverse prod) action) new-prods) - (setf prod nil - action nil - phase :prod)) - ((eq tok :reduce) - (setf phase :action)) - ((eq tok :tag) - (setf phase :tag)) - ((eq phase :tag) - (setf action `(cons ,tok $vars))) - ((eq phase :action) - (setf action tok)) - ((eq phase :prod) - (push tok prod))) - finally - (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) + (loop + for tok in productions + with prod = nil + with action = nil + with phase = nil + with new-prods = nil + while tok + do (cond ((eq tok :=) + (push (list (nreverse prod) action) new-prods) + (setf prod nil + action nil + phase :prod)) + ((eq tok :reduce) + (setf phase :action)) + ((eq tok :tag) + (setf phase :tag)) + ((eq phase :tag) + (setf action `(cons ,tok $vars))) + ((eq phase :action) + (setf action tok)) + ((eq phase :prod) + (push tok prod))) + finally + (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) (insert-rule-in-current-grammar name (transform productions)))) (defmacro defrule (name &rest productions) @@ -124,9 +124,9 @@ call to INSERT-RULE-IN-CURRENT-GRAMMAR." return it." (insert-rule-in-current-grammar (gensym (concatenate 'string "OPT-" - (if (rule-p token) - (symbol-name (rule-name token)) - (string-upcase token)))) + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))) `(((,token)) (())))) (defun make-alternative-rule (tokens) @@ -134,24 +134,24 @@ return it." (insert-rule-in-current-grammar (gensym "ALT") (mapcar #'(lambda (alternative) - `((,alternative))) - tokens))) + `((,alternative))) + tokens))) (defun make-nonempty-list-rule (token &optional separator) "Make a rule for a non-empty list (+ syntax) and return it." (let ((rule-name (gensym (concatenate 'string "NELST-" - (if (rule-p token) - (symbol-name (rule-name token)) - (string-upcase token)))))) + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))))) (insert-rule-in-current-grammar rule-name (if separator - `(((,token ,separator ,rule-name) - (cons $1 $3)) - ((,token) ,#'list)) - `(((,token ,rule-name) - (cons $1 $2)) - ((,token) ,#'list)))))) + `(((,token ,separator ,rule-name) + (cons $1 $3)) + ((,token) ,#'list)) + `(((,token ,rule-name) + (cons $1 $2)) + ((,token) ,#'list)))))) (defun make-list-rule (token &optional separator) "Make a rule for a possibly empty list (* syntax) return it." @@ -166,14 +166,14 @@ return it." or (* NAME) or (+ NAME). This is used by the DEFRULE macro." (if (symbolp tok) (let* ((name (symbol-name tok)) - (last (char name (1- (length name)))) - ;; this looks silly but we need to make sure that we - ;; return symbols interned in this package, no one else - (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) - (if (and (> (length name) 1) op) - (list op - (intern (subseq name 0 (1- (length name))))) - tok)) + (last (char name (1- (length name)))) + ;; this looks silly but we need to make sure that we + ;; return symbols interned in this package, no one else + (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) + (if (and (> (length name) 1) op) + (list op + (intern (subseq name 0 (1- (length name))))) + tok)) tok)) (defun EBNF-to-SEBNF (tokens) @@ -184,10 +184,10 @@ EBNF syntax into a sexp-based EBNF syntax or SEBNF." for token = (expand-production-token tok) with new-tokens = '() do (cond ((member token '(* + ?)) - (setf (car new-tokens) - (list token (car new-tokens)))) - (t - (push token new-tokens))) + (setf (car new-tokens) + (list token (car new-tokens)))) + (t + (push token new-tokens))) finally (return (nreverse new-tokens)))) (defun SEBNF-to-BNF (tokens) @@ -195,21 +195,21 @@ EBNF syntax into a sexp-based EBNF syntax or SEBNF." it into BNF. The production is simplified but the current grammar is populated with additional rules." (flet ((make-complex-token-rule (tok) - (ecase (car tok) - (* (apply #'make-list-rule (cdr tok))) - (+ (apply #'make-nonempty-list-rule (cdr tok))) - (? (make-optional-rule (cadr tok))) - (or (make-alternative-rule (cdr tok)))))) + (ecase (car tok) + (* (apply #'make-list-rule (cdr tok))) + (+ (apply #'make-nonempty-list-rule (cdr tok))) + (? (make-optional-rule (cadr tok))) + (or (make-alternative-rule (cdr tok)))))) (loop for token in tokens with new-tokens = '() with keywords = '() do (cond ((listp token) - (push (make-complex-token-rule token) new-tokens)) - (t - (push token new-tokens) - (when (const-terminal-p token) - (push token keywords)))) + (push (make-complex-token-rule token) new-tokens)) + (t + (push token new-tokens) + (when (const-terminal-p token) + (push token keywords)))) finally (return (values (nreverse new-tokens) keywords))))) (defun make-default-action-function (name tokens) @@ -220,28 +220,28 @@ list and in case only a variable token is available that one is returned (not included in a list). If all the tokens are constant, then all of them are returned in a list." (cond ((null tokens) - ;; if the production matched the empty list (no tokens) we - ;; return always nil, that is the function LIST applied to no - ;; arguments - #'list) - ((null (cdr tokens)) - ;; if the production matches just one token we simply return - ;; that - #'identity) - (*smart-default-reduction* - ;; If we are required to be "smart" then create a function - ;; that simply returns the non static tokens of the - ;; production. If the production doesn't have nonterminal, - ;; then return all the tokens. If the production has only - ;; one argument then return that one only. - (make-action-function name tokens '(cond - ((null $vars) $all) - ((null (cdr $vars)) (car $vars)) - (t $vars)))) - (t - ;; in all the other cases we return all the token matching - ;; the production - #'list))) + ;; if the production matched the empty list (no tokens) we + ;; return always nil, that is the function LIST applied to no + ;; arguments + #'list) + ((null (cdr tokens)) + ;; if the production matches just one token we simply return + ;; that + #'identity) + (*smart-default-reduction* + ;; If we are required to be "smart" then create a function + ;; that simply returns the non static tokens of the + ;; production. If the production doesn't have nonterminal, + ;; then return all the tokens. If the production has only + ;; one argument then return that one only. + (make-action-function name tokens '(cond + ((null $vars) $all) + ((null (cdr $vars)) (car $vars)) + (t $vars)))) + (t + ;; in all the other cases we return all the token matching + ;; the production + #'list))) (defun make-production-from-descr (name production-description) "Take a production NAME and its description in the form of a sexp @@ -250,28 +250,28 @@ keywords." (destructuring-bind (tokens &optional action) production-description (let ((expanded-tokens (EBNF-to-SEBNF tokens))) (multiple-value-bind (production-tokens keywords) - (sebnf-to-bnf expanded-tokens) + (sebnf-to-bnf expanded-tokens) (let ((funct - (cond ((not action) - (make-default-action-function name expanded-tokens)) - ((or (listp action) - ;; the case when the action is simply to - ;; return a token (ie $2) or a constant value - (symbolp action)) - (make-action-function name expanded-tokens action)) - ((functionp action) - action) - (t ; action is a constant - #'(lambda (&rest args) - (declare (ignore args)) - action))))) - (values - ;; Make a promise instead of actually resolving the - ;; nonterminals. This avoids endless recursion. - (make-production :tokens production-tokens - :tokens-length (length production-tokens) - :action funct) - keywords)))))) + (cond ((not action) + (make-default-action-function name expanded-tokens)) + ((or (listp action) + ;; the case when the action is simply to + ;; return a token (ie $2) or a constant value + (symbolp action)) + (make-action-function name expanded-tokens action)) + ((functionp action) + action) + (t ; action is a constant + #'(lambda (&rest args) + (declare (ignore args)) + action))))) + (values + ;; Make a promise instead of actually resolving the + ;; nonterminals. This avoids endless recursion. + (make-production :tokens production-tokens + :tokens-length (length production-tokens) + :action funct) + keywords)))))) (defun remove-immediate-left-recursivity (rule) "Turn left recursive rules of the type @@ -281,7 +281,7 @@ into A2 -> x A2 | E where E is the empty production." (let ((name (rule-name rule)) - (productions (rule-productions rule))) + (productions (rule-productions rule))) (loop for prod in productions for tokens = (prod-tokens prod) @@ -291,40 +291,40 @@ where E is the empty production." else collect prod into non-left-recursive finally - ;; found any left recursive production? - (when left-recursive - (warn "rule ~S is left recursive" name) - (let ((new-rule (make-rule :name (gensym "REWRITE")))) - ;; A -> y A2 - (setf (rule-productions rule) - (mapcar #'(lambda (p) - (let ((tokens (prod-tokens p)) - (action (prod-action p))) - (make-production :tokens (append tokens (list new-rule)) - :tokens-length (1+ (prod-tokens-length p)) - :action #'(lambda (&rest args) - (let ((f-A2 (car (last args))) - (head (butlast args))) - (funcall f-A2 (apply action head))))))) - non-left-recursive)) - ;; A2 -> x A2 | E - (setf (rule-productions new-rule) - (append - (mapcar #'(lambda (p) - (let ((tokens (prod-tokens p)) - (action (prod-action p))) - (make-production :tokens (append (cdr tokens) (list new-rule)) - :tokens-length (prod-tokens-length p) - :action #'(lambda (&rest args) - (let ((f-A2 (car (last args))) - (head (butlast args))) - #'(lambda (x) - (funcall f-A2 (apply action x head)))))))) - left-recursive) - (list - (make-production :tokens nil - :tokens-length 0 - :action #'(lambda () #'(lambda (arg) arg))))))))))) + ;; found any left recursive production? + (when left-recursive + (warn "rule ~S is left recursive" name) + (let ((new-rule (make-rule :name (gensym "REWRITE")))) + ;; A -> y A2 + (setf (rule-productions rule) + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append tokens (list new-rule)) + :tokens-length (1+ (prod-tokens-length p)) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + (funcall f-A2 (apply action head))))))) + non-left-recursive)) + ;; A2 -> x A2 | E + (setf (rule-productions new-rule) + (append + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append (cdr tokens) (list new-rule)) + :tokens-length (prod-tokens-length p) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + #'(lambda (x) + (funcall f-A2 (apply action x head)))))))) + left-recursive) + (list + (make-production :tokens nil + :tokens-length 0 + :action #'(lambda () #'(lambda (arg) arg))))))))))) (defun remove-left-recursivity-from-rules (rules) (loop @@ -338,9 +338,9 @@ where E is the empty production." (loop for rule being each hash-value in rules do (loop - for production in (rule-productions rule) - do (setf (prod-tokens production) - (resolve-nonterminals (prod-tokens production) rules))))) + for production in (rule-productions rule) + do (setf (prod-tokens production) + (resolve-nonterminals (prod-tokens production) rules))))) (defun make-rule-productions (rule-name production-descriptions) "Return a production object that belongs to RULE-NAME made according @@ -352,12 +352,12 @@ to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR." with productions = '() with keywords = '() do (progn - (multiple-value-bind (production keyws) - (make-production-from-descr prod-name descr) - (push production productions) - (setf keywords (append keyws keywords)))) + (multiple-value-bind (production keyws) + (make-production-from-descr prod-name descr) + (push production productions) + (setf keywords (append keyws keywords)))) finally (return - (values (nreverse productions) keywords)))) + (values (nreverse productions) keywords)))) (defun create-rule (name production-descriptions) "Return a new rule object together with a list of keywords making up @@ -365,7 +365,7 @@ the production definitions." (multiple-value-bind (productions keywords) (make-rule-productions name production-descriptions) (values (make-rule :name name :productions productions) - keywords))) + keywords))) (defun insert-rule-in-current-grammar (name productions) "Add rule to the current grammar and its keywords to the keywords @@ -384,18 +384,18 @@ instead." "Given a list of production tokens, try to expand the nonterminal ones with their respective rule from the the RULES pool." (flet ((resolve-symbol (sym) - (or (find-rule sym rules) - sym))) + (or (find-rule sym rules) + sym))) (mapcar #'(lambda (tok) - (if (symbolp tok) - (resolve-symbol tok) - tok)) - tokens))) + (if (symbolp tok) + (resolve-symbol tok) + tok)) + tokens))) (defun reset-grammar () "Empty the current grammar from any existing rule." (setf *rules* (make-rules-table) - *keywords* (make-keywords-table))) + *keywords* (make-keywords-table))) (defun generate-grammar (&optional (equal-p #'string-equal)) "Return a GRAMMAR structure suitable for the PARSE function, using @@ -404,5 +404,5 @@ match the input tokens; it defaults to STRING-EQUAL." (resolve-all-nonterminals *rules*) (remove-left-recursivity-from-rules *rules*) (make-grammar :rules *rules* - :keywords *keywords* - :equal-p equal-p)) + :keywords *keywords* + :equal-p equal-p)) diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp index 328be1dcf3..c15d26fe39 100644 --- a/third_party/lisp/npg/src/parser.lisp +++ b/third_party/lisp/npg/src/parser.lisp @@ -43,9 +43,9 @@ Tune this if your grammar is unusually complex.") (when *debug* (format *debug* "reducing ~S on ~S~%" production arguments)) (flet ((safe-token-value (token) - (if (token-p token) - (token-value token) - token))) + (if (token-p token) + (token-value token) + token))) (apply (prod-action production) (mapcar #'safe-token-value arguments)))) (defgeneric later-position (pos1 pos2) @@ -75,120 +75,120 @@ supposed to specialise this method.")) Return the reduced values according to the nonterminal actions. Raise an error on failure." (declare (type grammar grammar) - (type symbol start)) + (type symbol start)) (labels ((match-token (expected token) - (when *debug* - (format *debug* "match-token ~S ~S -> " expected token)) - (let ((res (cond ((symbolp expected) - ;; non-costant terminal (like identifiers) - (eq expected (token-type token))) - ((and (stringp expected) - (stringp (token-value token))) - ;; string costant terminal - (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) - ((functionp expected) - ;; custom equality predicate (must be able - ;; to deal with token objects) - (funcall expected token)) - ;; all the rest - (t (equal expected (token-value token)))))) - (when *debug* - (format *debug* "~Amatched~%" (if res "" "not "))) - res)) + (when *debug* + (format *debug* "match-token ~S ~S -> " expected token)) + (let ((res (cond ((symbolp expected) + ;; non-costant terminal (like identifiers) + (eq expected (token-type token))) + ((and (stringp expected) + (stringp (token-value token))) + ;; string costant terminal + (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) + ((functionp expected) + ;; custom equality predicate (must be able + ;; to deal with token objects) + (funcall expected token)) + ;; all the rest + (t (equal expected (token-value token)))))) + (when *debug* + (format *debug* "~Amatched~%" (if res "" "not "))) + res)) (match (expected matched #+debug depth) - (declare (list expected matched) - #+debug (fixnum depth)) - (let ((first-expected (car expected))) - (cond #+debug ((> depth *maximum-recursion-depth*) - (error "endless recursion on ~A ~A at ~A expecting ~S" - (token-type (car matched)) (token-value (car matched)) - (token-position (car matched)) expected)) - ((eq first-expected :any) - (match (cdr expected) (cdr matched) #+debug depth)) - ;; This is a trick to obtain partial parses. When we - ;; reach this expected token we assume we succeeded - ;; the parsing and return the remaining tokens as - ;; part of the match. - ((eq first-expected :rest) - ;; we could be at the end of input so we check this - (unless (cdr matched) - (setf (cdr matched) (list :rest))) - (list nil nil)) - ((rule-p first-expected) - ;; If it's a rule, then we try to match all its - ;; productions. We return the first that succeeds. - (loop - for production in (rule-productions first-expected) - for production-tokens of-type list = (prod-tokens production) - with last-error-position = nil - with last-error = nil - for (error-position error-descr) = - (progn - (when *debug* - (format *debug* "trying to match ~A: ~S~%" - (rule-name first-expected) production-tokens)) - (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) - do (cond ((not error-position) - (return (let ((args-count (prod-tokens-length production))) - (setf (cdr matched) - (cons (reduce-production - production - (subseq (the list (cdr matched)) 0 args-count)) - (nthcdr (1+ args-count) matched))) - (list nil nil)))) - ((or (not last-error) - (later-position error-position last-error-position)) - (setf last-error-position error-position - last-error error-descr))) - ;; if everything fails return the "best" error - finally (return (list last-error-position - (if *debug* - #'(lambda () - (format nil "~A, trying to match ~A" - (funcall (the function last-error)) - (rule-name first-expected))) - last-error))))) - (t - ;; if necessary load the next tokens - (when (null (cdr matched)) - (setf (cdr matched) (read-next-tokens tokenizer))) - (cond ((and (or (null expected) (eq first-expected :eof)) - (null (cdr matched))) - ;; This point is reached only once for each complete - ;; parsing. The expected tokens and the input - ;; tokens have been exhausted at the same time. - ;; Hence we succeeded the parsing. - (setf (cdr matched) (list :eof)) - (list nil nil)) - ((null expected) - ;; Garbage at end of parsing. This may mean that we - ;; have considered a production completed too soon. - (list (token-position (car matched)) - #'(lambda () - "garbage at end of parsing"))) - ((null (cdr matched)) - ;; EOF error - (list :eof - #'(lambda () - (format nil "end of input expecting ~S" expected)))) - (t ;; normal token - (let ((first-token (cadr matched))) - (if (match-token first-expected first-token) - (match (cdr expected) (cdr matched) #+debug depth) - ;; failed: we return the error - (list (token-position first-token) - #'(lambda () - (format nil "expected ~S but got ~S ~S" - first-expected (token-type first-token) - (token-value first-token))))))))))))) + (declare (list expected matched) + #+debug (fixnum depth)) + (let ((first-expected (car expected))) + (cond #+debug ((> depth *maximum-recursion-depth*) + (error "endless recursion on ~A ~A at ~A expecting ~S" + (token-type (car matched)) (token-value (car matched)) + (token-position (car matched)) expected)) + ((eq first-expected :any) + (match (cdr expected) (cdr matched) #+debug depth)) + ;; This is a trick to obtain partial parses. When we + ;; reach this expected token we assume we succeeded + ;; the parsing and return the remaining tokens as + ;; part of the match. + ((eq first-expected :rest) + ;; we could be at the end of input so we check this + (unless (cdr matched) + (setf (cdr matched) (list :rest))) + (list nil nil)) + ((rule-p first-expected) + ;; If it's a rule, then we try to match all its + ;; productions. We return the first that succeeds. + (loop + for production in (rule-productions first-expected) + for production-tokens of-type list = (prod-tokens production) + with last-error-position = nil + with last-error = nil + for (error-position error-descr) = + (progn + (when *debug* + (format *debug* "trying to match ~A: ~S~%" + (rule-name first-expected) production-tokens)) + (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) + do (cond ((not error-position) + (return (let ((args-count (prod-tokens-length production))) + (setf (cdr matched) + (cons (reduce-production + production + (subseq (the list (cdr matched)) 0 args-count)) + (nthcdr (1+ args-count) matched))) + (list nil nil)))) + ((or (not last-error) + (later-position error-position last-error-position)) + (setf last-error-position error-position + last-error error-descr))) + ;; if everything fails return the "best" error + finally (return (list last-error-position + (if *debug* + #'(lambda () + (format nil "~A, trying to match ~A" + (funcall (the function last-error)) + (rule-name first-expected))) + last-error))))) + (t + ;; if necessary load the next tokens + (when (null (cdr matched)) + (setf (cdr matched) (read-next-tokens tokenizer))) + (cond ((and (or (null expected) (eq first-expected :eof)) + (null (cdr matched))) + ;; This point is reached only once for each complete + ;; parsing. The expected tokens and the input + ;; tokens have been exhausted at the same time. + ;; Hence we succeeded the parsing. + (setf (cdr matched) (list :eof)) + (list nil nil)) + ((null expected) + ;; Garbage at end of parsing. This may mean that we + ;; have considered a production completed too soon. + (list (token-position (car matched)) + #'(lambda () + "garbage at end of parsing"))) + ((null (cdr matched)) + ;; EOF error + (list :eof + #'(lambda () + (format nil "end of input expecting ~S" expected)))) + (t ;; normal token + (let ((first-token (cadr matched))) + (if (match-token first-expected first-token) + (match (cdr expected) (cdr matched) #+debug depth) + ;; failed: we return the error + (list (token-position first-token) + #'(lambda () + (format nil "expected ~S but got ~S ~S" + first-expected (token-type first-token) + (token-value first-token))))))))))))) (declare (inline match-token)) (let ((result (list :head))) (destructuring-bind (error-position error) - (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) - (when error-position - (error "~A at ~A~%" (funcall (the function error)) error-position)) - (cadr result))))) + (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) + (when error-position + (error "~A at ~A~%" (funcall (the function error)) error-position)) + (cadr result))))) (defgeneric terminals-in-grammar (grammar-or-hashtable) (:documentation @@ -199,11 +199,11 @@ an error on failure." for rule being each hash-value of grammar with terminals = '() do (loop - for prod in (rule-productions rule) - do (loop - for tok in (prod-tokens prod) - when (symbolp tok) - do (pushnew tok terminals))) + for prod in (rule-productions rule) + do (loop + for tok in (prod-tokens prod) + when (symbolp tok) + do (pushnew tok terminals))) finally (return terminals))) (defmethod terminals-in-grammar ((grammar grammar)) @@ -211,9 +211,9 @@ an error on failure." (defun print-grammar-figures (grammar &optional (stream *standard-output*)) (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%" - (hash-table-count (grammar-rules grammar)) - (hash-table-count (grammar-keywords grammar)) - (terminals-in-grammar (grammar-rules grammar)))) + (hash-table-count (grammar-rules grammar)) + (hash-table-count (grammar-keywords grammar)) + (terminals-in-grammar (grammar-rules grammar)))) (defun grammar-keyword-p (keyword grammar) diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp index 4684a8e705..3e479c4ac2 100644 --- a/third_party/lisp/sclf/directory.lisp +++ b/third_party/lisp/sclf/directory.lisp @@ -29,25 +29,25 @@ (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) + '(: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))) + :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))) + (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) @@ -60,11 +60,11 @@ 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))) + :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 @@ -76,42 +76,42 @@ broken symbolic links in your filesystem." (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)))) + (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)) + (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)) + #'(lambda (,file) + ,@body) + :truenamep ,truenamep + :test ,test + :depth-first ,depth-first)) (defun empty-directory-p (pathname) (and (directory-p pathname) @@ -142,7 +142,7 @@ system.)" (be files '() (do-directory-tree (file root-pathname :truenamep truenamep) (when (funcall matcher-function file) - (push file files))) + (push file files))) (nreverse files))) (defun delete-directory-tree (pathname) @@ -156,17 +156,17 @@ 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)))) + (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))) + (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.") @@ -180,19 +180,19 @@ will be assigned to it. Return PATHNAME." "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)))))) + (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)))) + :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. @@ -212,7 +212,7 @@ 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) + (progn ,@body) (delete-directory-tree ,path)))) (defun current-directory () @@ -229,44 +229,44 @@ are defined." ;; 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)))))) + (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) + &key (start 0) end junk-allowed) #+sbcl (sb-ext:parse-native-namestring string host defaults - :start start - :end end - :junk-allowed junk-allowed) + :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))) + (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))) + (namestring pathname))) (defun native-file-namestring (pathname) #+sbcl (sb-ext:native-namestring - (make-pathname :name (pathname-name pathname) - :type (pathname-type pathname))) + (make-pathname :name (pathname-name pathname) + :type (pathname-type pathname))) #+cmu (be lisp::*ignore-wildcards* t - (file-namestring pathname))) + (file-namestring pathname))) (defun native-pathname (thing) #+sbcl (sb-ext:native-pathname thing) #+cmu (be lisp::*ignore-wildcards* t - (pathname thing))) + (pathname thing))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -277,9 +277,9 @@ are defined." (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)) + (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) @@ -287,8 +287,8 @@ are defined." #-(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))) + #+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) @@ -324,27 +324,27 @@ are defined." (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) + size atime mtime ctime + blksize blocks) (#+cmu unix:unix-lstat #+sbcl sb-unix:unix-lstat (if (stringp pathname) - pathname - (native-namestring 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)))) + :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 @@ -383,9 +383,9 @@ contents." (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))) + (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) diff --git a/third_party/lisp/sclf/lazy.lisp b/third_party/lisp/sclf/lazy.lisp index 18f6bfdb71..34bae82ebb 100644 --- a/third_party/lisp/sclf/lazy.lisp +++ b/third_party/lisp/sclf/lazy.lisp @@ -41,13 +41,13 @@ (if (forced-p promise) (promise-value promise) (prog1 (setf (promise-value promise) - (funcall (promise-procedure promise))) - (setf (promise-procedure promise) nil)))) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) (defmacro deflazy (name value &optional documentation) `(defparameter ,name (lazy ,value) ,@(when documentation - (list documentation)))) + (list documentation)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -71,8 +71,8 @@ any other.")) (defclass lazy-slot-mixin () ((lazy-function :initarg :lazy - :reader lazy-slot-function - :initform nil)) + :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 @@ -100,20 +100,20 @@ instance as argument.")) (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)) + (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)) @@ -122,7 +122,7 @@ instance as argument.")) ;; 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))) + (funcall (lazy-slot-function slot) instance))) (call-next-method)) (defun reset-lazy-slots (object) @@ -131,4 +131,4 @@ 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 + (slot-makunbound object (slot-definition-name slot)))))) \ No newline at end of file diff --git a/third_party/lisp/sclf/mp/cmu.lisp b/third_party/lisp/sclf/mp/cmu.lisp index 6617f6dadd..1bdbba7989 100644 --- a/third_party/lisp/sclf/mp/cmu.lisp +++ b/third_party/lisp/sclf/mp/cmu.lisp @@ -30,14 +30,14 @@ (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))) + :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))) + ,@(when wait (list :wait wait)) + ,@(when timeout (list :timeout timeout))) ,@forms)) (defstruct condition-variable @@ -47,31 +47,31 @@ (defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp #+i486 (kernel:%instance-set-conditional - lock 2 mp:*current-process* nil) + lock 2 mp:*current-process* nil) #-i486 (when (eq (lock-process lock) mp:*current-process*) - (setf (lock-process lock) nil))) + (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)) + (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)))))) + (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)) @@ -79,12 +79,12 @@ ;; 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)))) + (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)) @@ -100,7 +100,7 @@ (defun destroy-process (process) ;; silnetly ignore a process that is trying to destroy itself (unless (eq (mp:current-process) - process) + process) (mp:destroy-process process))) (defun restart-process (process) diff --git a/third_party/lisp/sclf/mp/sbcl.lisp b/third_party/lisp/sclf/mp/sbcl.lisp index 7f47ec9c61..a2cf497ff9 100644 --- a/third_party/lisp/sclf/mp/sbcl.lisp +++ b/third_party/lisp/sclf/mp/sbcl.lisp @@ -24,8 +24,8 @@ (in-package :sclf) (defstruct (process - (:constructor %make-process) - (:predicate processp)) + (:constructor %make-process) + (:predicate processp)) name state whostate @@ -53,10 +53,10 @@ (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)) + 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")) @@ -65,7 +65,7 @@ (defun make-process (function &key name) (let ((p (%make-process :name name - :function function))) + :function function))) (sb-thread:with-mutex (*all-processes-lock*) (pushnew p *all-processes*)) (restart-process p))) @@ -73,7 +73,7 @@ (defun process-kill-thread (process) (let ((thread (process-thread process))) (when (and thread - (sb-thread:thread-alive-p 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. @@ -85,13 +85,13 @@ (defun restart-process (p) (labels ((boing () - (let ((*current-process* p) - (function (process-function p))) - (when function - (funcall function))))) + (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))) + (sb-thread:make-thread #'boing :name (process-name p))) p))) (defun destroy-process (process) @@ -115,26 +115,26 @@ (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))) + (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))) + (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))) + (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) @@ -175,13 +175,13 @@ (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)))))) + (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) @@ -193,24 +193,24 @@ `(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)))))) + (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)) + (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) diff --git a/third_party/lisp/sclf/package.lisp b/third_party/lisp/sclf/package.lisp index 652194f93c..565ab301c7 100644 --- a/third_party/lisp/sclf/package.lisp +++ b/third_party/lisp/sclf/package.lisp @@ -25,234 +25,234 @@ (defpackage :sclf (:use :common-lisp - ;; we need the MOP for lazy.lisp and serial.lisp - #+cmu :pcl - #+sbcl :sb-mop) + ;; 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") + #-(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) + #: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 + #: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 + ;; 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 - )) + ;; 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 index dfb56a8ded..a9754b7569 100644 --- a/third_party/lisp/sclf/sclf.asd +++ b/third_party/lisp/sclf/sclf.asd @@ -49,10 +49,10 @@ uses, too small to fit anywhere else." (: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"))))))) + :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 index 0d587da8eb..dfbc2078c8 100644 --- a/third_party/lisp/sclf/sclf.lisp +++ b/third_party/lisp/sclf/sclf.lisp @@ -63,22 +63,22 @@ (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))))) + (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))))) + (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))) @@ -93,7 +93,7 @@ useless. This macro works around that problem." "Gensym all SYMBOLS and make them available in BODY. See also LET-GENSYMS." `(let ,(mapcar #'(lambda (s) - (list s '(gensym))) symbols) + (list s '(gensym))) symbols) ,@body)) (defun s+ (&rest strings) @@ -103,14 +103,14 @@ See also LET-GENSYMS." (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)))) + (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))))) + (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 @@ -119,13 +119,13 @@ need to be the same length." (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))))) + 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 @@ -134,8 +134,8 @@ ESCAPE-CHARACTER." (loop for c across string when (or (char= c character) - (and escape-escape - (char= c escape-character))) + (and escape-escape + (char= c escape-character))) do (write-char escape-character stream) do (write-char c stream)))) @@ -144,8 +144,8 @@ ESCAPE-CHARACTER." (defmacro aif (test then &optional else) `(be it ,test (if it - ,then - ,else))) + ,then + ,else))) (defmacro awhen (test &body then) `(be it ,test @@ -155,13 +155,13 @@ ESCAPE-CHARACTER." (defmacro acond (&body forms) (when forms `(aif ,(caar forms) - (progn ,@(cdar forms)) - (acond ,@(cdr 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)))))) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) (defmacro acase (condition &body forms) `(be it ,condition @@ -190,20 +190,20 @@ ESCAPE-CHARACTER." "Return SEQUENCE if it's not empty, otherwise NIL. NIL is indeed empty." (when (or (listp sequence) - (not (zerop (length 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)) + (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)) + (find element bag)) sequence find-args)) (defun split-at (bag sequence &key (start 0) key) "Split SEQUENCE at occurence of any element from BAG. @@ -211,15 +211,15 @@ 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)))))))) + (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) @@ -229,12 +229,12 @@ 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))) + (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)) @@ -244,11 +244,11 @@ not nil then split at SEPARATOR only if it's not preceded by ESCAPE." ((not end) (list substring)) (t - (cons substring (parse (1+ end))))))) + (cons substring (parse (1+ end))))))) (skip-empty - '()) + '()) (t - (list ""))))) + (list ""))))) (parse 0))) (defun copy-stream (in out) @@ -262,15 +262,15 @@ not nil then split at SEPARATOR only if it's not preceded by ESCAPE." (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))) + 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) @@ -279,7 +279,7 @@ not nil then split at SEPARATOR only if it's not preceded by ESCAPE." (defun symlink-file (src dst &key (if-exists :error)) (when (and (eq :supersede if-exists) - (probe-file dst)) + (probe-file dst)) (delete-file dst)) #+sbcl (sb-posix:symlink src dst) #+cmu(unix:unix-symlink (native-namestring src) (native-namestring dst)) @@ -302,8 +302,8 @@ signalling an error." for line = (read-line stream nil) for i from 0 while (and line - (or (not n) - (< i n))) + (or (not n) + (< i n))) collect line)) (defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) @@ -311,24 +311,24 @@ signalling an error." 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)) + :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))) + (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) + :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) @@ -343,9 +343,9 @@ DEFAULT is returned." (read in))) (:value (handler-case (with-open-file (in pathname) - (read in)) + (read in)) (t () - default))))) + 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 @@ -357,10 +357,10 @@ with pathname PATHNAME." "Concatenate the strings in LIST interposing SEPARATOR (default nothing) between them." (reduce #'(lambda (&rest args) - (if args - (s+ (car args) separator (cadr args)) - "")) - list)) + (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) @@ -369,18 +369,18 @@ 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))))) + (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. @@ -393,10 +393,10 @@ Otherwise return the same string unchanged." (defmacro until (test &body body) (with-gensyms (result) `(loop - for ,result = ,test - until ,result - do (progn ,@body) - finally (return ,result)))) + for ,result = ,test + until ,result + do (progn ,@body) + finally (return ,result)))) (defun keywordify (string) (intern (string-upcase string) :keyword)) @@ -419,7 +419,7 @@ 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))))) + :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 @@ -435,14 +435,14 @@ file, otherwise *TMP-FILE-DEFAULTS* is used." ;; 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)) + (error "Can't create temporary file with open direction ~A." it)) (setf open-args (append '(:direction :output) - open-args))) + 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 #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) @@ -451,11 +451,11 @@ 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) + (progn ,@body) (close ,stream) ;; body may decide to rename the file so we must ignore the errors (ignore-errors - (delete-file (pathname ,stream)))))) + (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 @@ -468,17 +468,17 @@ 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) + (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)) + (type-of seq) + 'list) + (list item) seq test :key key)) (defmacro f++ (x &optional (delta 1)) "Same as INCF but hopefully optimised for fixnums." @@ -500,46 +500,46 @@ Examples: (soundex \"Ladd\") => \"L300\"" (declare (type string word)) (flet ((translate-char (char) - (awhen (position char "BFPVCGJKQSXZDTLMNR") - (elt "111122222222334556" it)))) + (awhen (position char "BFPVCGJKQSXZDTLMNR") + (elt "111122222222334556" it)))) (let ((key (make-string key-length :initial-element #\0)) - (word-length (length word))) + (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)))))) + 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))) + (l2 (split-at +whitespace+ string2))) (and (= (length l1) (length l2)) - (every #'string= (mapcar #'soundex l1) (mapcar #'soundex 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"))) + (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) + (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -596,17 +596,17 @@ one (if any)." (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))))) + :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) + ((not ,cursor) ,result) (be ,var (dle-value ,cursor) - ,@body)))) + ,@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 @@ -614,14 +614,14 @@ modify the element's value." (be cursor (gensym) `(symbol-macrolet ((,var (dle-value ,cursor))) (do ((,cursor ,dle (dle-next ,cursor))) - ((not ,cursor) ,result) - ,@body)))) + ((not ,cursor) ,result) + ,@body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass double-linked-list () ((elements :type double-linked-element - :documentation "The actual list of elements held by this object.") + :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 @@ -632,13 +632,13 @@ from either end.")) (call-next-method) (with-slots (last-element elements) object (setf last-element (make-double-linked-element) - elements last-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)) + (push e elements)) (format stream "elements=~S" (nreverse elements))))) (defgeneric pop-first (double-linked-list) @@ -672,8 +672,8 @@ from either end.")) (with-slots (elements) list (when (dle-next elements) (prog1 (dle-value elements) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))))) + (setf (dle-previous (dle-next elements)) nil + elements (dle-next elements)))))) (defmethod push-first (value (list double-linked-list)) (with-slots (elements) list @@ -687,11 +687,11 @@ from either end.")) (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)))))) + (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)) @@ -699,7 +699,7 @@ from either end.")) ((not (dle-next cursor))) (be value (dle-value cursor) (when (funcall test (funcall key value) object) - (return cursor))))) + (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) @@ -708,9 +708,9 @@ from either end.")) (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)))) + (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) @@ -718,9 +718,9 @@ from either end.")) 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) + ((not (dle-next ,cursor)) ,result) (be ,var (dle-value ,cursor) - ,@body)))) + ,@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 @@ -728,21 +728,21 @@ 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)))) + ((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.") + :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.")) + :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.")) @@ -750,9 +750,9 @@ be limited.")) (defun dll-member-p (dle list) (with-slots (elements size) list (do ((e elements (dle-next e))) - ((not e)) + ((not e)) (when (eq e dle) - (return t))))) + (return t))))) (defmethod dll-remove ((cursor double-linked-element) (list limited-list)) (with-slots (size) list @@ -780,9 +780,9 @@ full." (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)))))) + (< 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 @@ -791,16 +791,16 @@ is full." (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)))))) + (< 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)) + :initarg :test)) (:documentation "A double linked list where elements are inserted in a sorted order.")) @@ -816,25 +816,25 @@ 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)))))) + ((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.") + :initarg :test + :documentation "The heap invariant.") (data :type array - :documentation "The heap tree representation."))) + :documentation "The heap tree representation."))) (defmethod initialize-instance ((heap heap) &rest args) (declare (ignore args)) @@ -850,7 +850,7 @@ element." for current = pos then parent for parent = (truncate (1- current) 2) until (or (zerop current) - (funcall less-than (aref data parent) (aref data current))) + (funcall less-than (aref data parent) (aref data current))) do (rotatef (aref data current) (aref data parent))))) (defmethod heap-add ((heap heap) item) @@ -879,13 +879,13 @@ element." 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)) + (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))))) @@ -901,7 +901,7 @@ element." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct (lru-cache-slot (:include double-linked-element) - (:conc-name lruc-slot-)) + (:conc-name lruc-slot-)) key) (defmethod print-object ((object lru-cache-slot) stream) @@ -914,24 +914,24 @@ 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.") + :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.") + :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.") + :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.") + :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.")) + :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 @@ -945,10 +945,10 @@ is required.")) (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))))) + elements-list last-element + elements-hash (if test + (make-hash-table :test test) + (make-hash-table))))) (defgeneric getcache (key cache) (:documentation @@ -966,7 +966,7 @@ is required.")) "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)) + (type lru-cache cache)) (with-slots (elements-list) cache ;; unless it's already the first (unless (eq slot elements-list) @@ -974,9 +974,9 @@ This will stretch its lifespan in the cache." (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)))) + (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." @@ -985,20 +985,20 @@ This will stretch its lifespan in the cache." (let ((second-last (lruc-slot-previous last-element))) (assert second-last) (when finalizer - (funcall finalizer (lruc-slot-value second-last))) + (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)) + (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)))) + (< 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)) @@ -1010,37 +1010,37 @@ This will stretch its lifespan in the 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)) + (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)))) + (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)) + (,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)))))) + (if ,found? + ,object + (let ((,my-value ,value)) + (setf (getcache ,my-key ,my-cache) ,my-value) + ,my-value)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1073,17 +1073,17 @@ store VALUE for later re-use." (defun find-uid (name) "Find the user id of NAME. Return an integer." #+sbcl (awhen (sb-posix:getpwnam name) - (sb-posix:passwd-uid it)) + (sb-posix:passwd-uid it)) #+cmu (awhen (unix:unix-getpwnam name) - (unix:user-info-uid it)) + (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")) + (:name "getuid") + (:arguments) + (:return-type ffi:int) + (:library "libc.so")) (defun getuid () "Return the Unix user id. This is an integer." @@ -1104,7 +1104,7 @@ user id." `(be ,ruid (getuid) (seteuid ,uid) (unwind-protect (progn ,@forms) - (seteuid ,ruid))))) + (seteuid ,ruid))))) (defun get-logname (&optional uid) "Return the login id of the user. This is a string and it is not @@ -1129,9 +1129,9 @@ file." (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.") - #\,)))) + #+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 @@ -1158,37 +1158,37 @@ 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)))) + (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))) + (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))) + (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)) + (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)))))) + (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 @@ -1198,21 +1198,21 @@ 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) + (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))))) + (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 @@ -1223,61 +1223,61 @@ 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)))) + `((,(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*)) + (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))) + (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))) + (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))) + (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 #\-))) + (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) @@ -1288,28 +1288,28 @@ trailing spaces must be removed from the string in advance." with amount = 0 with decimals = nil with negative = (when (and (not (zerop (length string))) - (char= #\- (char string 0))) - (incf start) - t) + (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)))))))) + (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)))) + (- amount) + amount)))) (defmacro with-package (name &body body) `(let ((*package* (find-package ,name))) @@ -1320,22 +1320,22 @@ trailing spaces must be removed from the string in advance." 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))) + (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"))))))) + (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 @@ -1368,31 +1368,31 @@ 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))))))) + (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))))) + (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 @@ -1401,7 +1401,7 @@ on exit. LOCK-ARGS are passed to MAKE-LOCK-FILES." `(be ,files (list ,@lock-files) (make-lock-files ,files ,@lock-args) (unwind-protect (progn ,@body) - (mapc #'delete-file ,files))))) + (mapc #'delete-file ,files))))) (defun getpid () #+cmu (unix:unix-getpid) @@ -1416,11 +1416,11 @@ 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))))) + (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." @@ -1446,11 +1446,11 @@ This does _not_ stop the error from propagating." (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)))) + (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) @@ -1479,30 +1479,30 @@ 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))))) + (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)) + (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))))) + ;; 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))))) + (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)))) + (when (member (symbol-package symbol) packages) + (forget symbol)))) (values)) (defun load-compiled (pathname &optional compiled-pathname) @@ -1513,13 +1513,13 @@ the compiled version is more recent than its source." (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)) + (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 @@ -1535,14 +1535,14 @@ also specify forms, not just variables." (let ((*print-pretty* nil)) `(let ((*print-circle* t)) (format t ,(format nil "~~&~{~A=~~:W~~%~}" things) - ,@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))))) + (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 @@ -1560,13 +1560,13 @@ 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) + ,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)))) + (setf (gethash ,key ,table) + (,function ,key)) + ,result)))) (defmacro save-file-excursion ((stream &optional position) &body forms) @@ -1587,9 +1587,9 @@ before FORMS. Optionally POSITION can be set to the starting offset." (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*)) + var + (intern var :keyword)) + ext:*environment-list*)) #+sbcl (sb-ext:posix-getenv (string var)) #+lispworks (hcl:getenv var) #+clisp (ext:getenv (string var)) @@ -1597,16 +1597,16 @@ before FORMS. Optionally POSITION can be set to the starting offset." (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")) + (: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")) + (:name "unsetenv") + (:arguments (name ffi:c-string)) + (:return-type ffi:int) + (:library "libc.so")) (defun setenv (name value &optional (overwrite t)) (typecase value @@ -1616,30 +1616,30 @@ before FORMS. Optionally POSITION can be set to the starting offset." (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))) + (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*)))) + (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))) + (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))) + (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*))) + (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))) + (error "unable to unsetenv ~A." name))) (defun (setf getenv) (value name) (if value @@ -1650,38 +1650,38 @@ before FORMS. Optionally POSITION can be set to the starting offset." #-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) + (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))))) + (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*))) + (append (list ,@(mapcar #'(lambda (vv) + (destructuring-bind (variable value) vv + `(cons ,(keywordify variable) + ,value))) + var-and-values)) + ext:*environment-list*))) ,@body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1693,7 +1693,7 @@ before FORMS. Optionally POSITION can be set to the starting offset." for l2 = (member item l :key key :test test) while l2 do (setf result l2 - l (cdr l2)) + l (cdr l2)) finally (return result))) @@ -1705,13 +1705,13 @@ before FORMS. Optionally POSITION can be set to the starting offset." (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))) + (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 index 936c616063..41d32e4c49 100644 --- a/third_party/lisp/sclf/serial.lisp +++ b/third_party/lisp/sclf/serial.lisp @@ -33,28 +33,28 @@ (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))))))))) + (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* diff --git a/third_party/lisp/sclf/sysproc.lisp b/third_party/lisp/sclf/sysproc.lisp index 85c2517e00..1dd559ebe3 100644 --- a/third_party/lisp/sclf/sysproc.lisp +++ b/third_party/lisp/sclf/sysproc.lisp @@ -66,8 +66,8 @@ error is not discarded.") #+cmu unix:sigcont #+sbcl sb-posix:sigcont) #+freebsd((:emt :emulate-instruction) - #+cmu unix:sigemt - #+sbcl sb-posix:sigemt) + #+cmu unix:sigemt + #+sbcl sb-posix:sigemt) ((:fpe :floating-point-exception) #+cmu unix:sigfpe #+sbcl sb-posix:sigfpe) @@ -189,29 +189,29 @@ error is not discarded.") "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)) + (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*)) + :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*)) + :search t + :wait wait + :pty pty + :input input + :output output + :error (or error *run-verbose*)) #-(or sbcl cmu) (error "Unsupported Lisp system.")) @@ -220,16 +220,16 @@ error is not discarded.") 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) + :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)) + (sysproc-input process) + process)) #-(or sbcl cmu) (error "Unsupported Lisp system.")) @@ -245,7 +245,7 @@ process." "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)) + :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 @@ -253,36 +253,36 @@ 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))) + ,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))))) + (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) diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp index ca1e1902a9..71b943aa43 100644 --- a/third_party/lisp/sclf/time.lisp +++ b/third_party/lisp/sclf/time.lisp @@ -50,15 +50,15 @@ "Return true if YEAR is a leap year." (and (zerop (mod year 4)) (or (not (zerop (mod year 100))) - (zerop (mod year 400))))) + (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))) + (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 @@ -66,12 +66,12 @@ 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))))) + (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 @@ -86,7 +86,7 @@ negative." "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) + (if (zerop zone) "Z" (multiple-value-bind (h m) (truncate (abs zone) 1.0) ;; Sign of time zone is reversed in ISO 8601 relative @@ -94,82 +94,82 @@ included if WITH-TIMEZONE-P is true." (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) + (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)))))) + (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))))) + ;; 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)))))) + (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: @@ -177,11 +177,11 @@ cover all the cases." (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))) + (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)) @@ -194,7 +194,7 @@ cover all the cases." 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))))) + (start (- 4 (week-day (add-days 4 Jan-1st))))) (add-days start Jan-1st))) (defun beginning-of-week (week year &optional time-zone) @@ -218,7 +218,7 @@ time can fall in the next year." "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)))) + (* 60 60 24)))) (defun week (time &optional time-zone) "Return the number of the week and the year TIME referes to. @@ -226,26 +226,26 @@ 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))) + (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))))) + (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")) + #("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")) + "August" "September" "October" "November" "December")) (defun month->string (month) "Return the month string corresponding to MONTH number." @@ -257,32 +257,32 @@ the last week of the previous or next year." (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)) + (hour (* minute 60)) + (day (* hour 24)) + (seconds span)) (macrolet ((split (divisor) - `(when (>= seconds ,divisor) - (prog1 (truncate seconds ,divisor) - (setf seconds (mod seconds ,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))))))))) + (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)) + epoch)) (defun next-monday (epoch &optional time-zone) "Return the universal time of the next Monday starting from |