diff options
Diffstat (limited to 'third_party')
22 files changed, 472 insertions, 3645 deletions
diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix index 9d3d6253f480..349ef397f761 100644 --- a/third_party/lisp/mime4cl/default.nix +++ b/third_party/lisp/mime4cl/default.nix @@ -7,12 +7,12 @@ depot.nix.buildLisp.library { deps = [ depot.third_party.lisp.babel - depot.third_party.lisp.sclf depot.third_party.lisp.npg depot.third_party.lisp.trivial-gray-streams ]; srcs = [ + ./ex-sclf.lisp ./package.lisp ./endec.lisp ./streams.lisp @@ -34,6 +34,7 @@ depot.nix.buildLisp.library { ;; override auto discovery which doesn't work in store (defvar *sample1-file* (pathname "${./test/sample1.msg}")) '') + ./test/temp-file.lisp ./test/endec.lisp ./test/address.lisp ./test/mime.lisp diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp new file mode 100644 index 000000000000..8a288cced801 --- /dev/null +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -0,0 +1,393 @@ +;;; ex-sclf.lisp --- subset of sclf used by mime4cl + +;;; Copyright (C) 2005-2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: sternenseemann <sternenseemann@systemli.org> +;;; Project: mime4cl +;;; +;;; mime4cl uses sclf for miscellaneous utility functions. sclf's portability +;;; is quite limited. Since mime4cl is the only thing in TVL's depot depending +;;; on sclf, it made more sense to strip down sclf to the extent mime4cl needed +;;; in order to lessen the burden of porting it to other CL implementations +;;; later. +;;; +;;; Eventually it probably makes sense to drop the utilities we don't like and +;;; merge the ones we do like into depot's own utility package, klatre. + +#+cmu (ext:file-comment "$Module: ex-sclf.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :mime4cl-ex-sclf + (:use :common-lisp) + (:export + #:be + #:be* + + #:aif + #:awhen + #:aand + #:it + + #:gcase + + #:with-gensyms + + #:split-at + #:split-string-at-char + #:+whitespace+ + #:whitespace-p + #:string-concat + #:s+ + #:string-starts-with + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + + #:queue + #:make-queue + #:queue-append + #:queue-pop + #:queue-empty-p + + #:save-file-excursion + #:read-file + + #:unix-file-stat + #:unix-stat + #:file-size + + #:promise + #:make-promise + #:lazy + #:force + #:forced-p + #:deflazy + + #:f++ + + #:week-day->string + #:month->string)) + +(in-package :mime4cl-ex-sclf) + +;; MACRO UTILS + +(defmacro with-gensyms ((&rest symbols) &body body) + "Gensym all SYMBOLS and make them available in BODY. +See also LET-GENSYMS." + `(let ,(mapcar #'(lambda (s) + (list s '(gensym))) symbols) + ,@body)) + +;; CONTROL FLOW + +(defmacro be (&rest bindings-and-body) + "Less-parenthetic let." + (let ((bindings + (loop + while (and (symbolp (car bindings-and-body)) + (cdr bindings-and-body)) + collect (list (pop bindings-and-body) + (pop bindings-and-body))))) + `(let ,bindings + ,@bindings-and-body))) + +(defmacro be* (&rest bindings-and-body) + "Less-parenthetic let*." + (let ((bindings + (loop + while (and (symbolp (car bindings-and-body)) + (cdr bindings-and-body)) + collect (list (pop bindings-and-body) + (pop bindings-and-body))))) + `(let* ,bindings + ,@bindings-and-body))) + +(defmacro aif (test then &optional else) + `(be it ,test + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(be it ,test + (when it + ,@then))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro gcase ((value &optional (test 'equalp)) &rest cases) + "Generic CASE macro. Match VALUE to CASES as if by the normal CASE +but use TEST as the comparison function, which defaults to EQUALP." + (with-gensyms (val) + `(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))))) + +;; SEQUENCES + +(defun position-any (bag sequence &rest position-args) + "Find any element of bag in sequence and return its position. +Accept any argument accepted by the POSITION function." + (apply #'position-if #'(lambda (element) + (find element bag)) sequence position-args)) + +(defun split-at (bag sequence &key (start 0) key) + "Split SEQUENCE at occurence of any element from BAG. +Contiguous occurences of elements from BAG are considered atomic; +so no empty sequence is returned." + (be len (length sequence) + (labels ((split-from (start) + (unless (>= start len) + (be sep (position-any bag sequence :start start :key key) + (cond ((not sep) + (list (subseq sequence start))) + ((> sep start) + (cons (subseq sequence start sep) + (split-from (1+ sep)))) + (t + (split-from (1+ start)))))))) + (split-from start)))) + +;; STRINGS + +(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(defun string-trim-whitespace (string) + (string-trim +whitespace+ string)) + +(defun string-right-trim-whitespace (string) + (string-right-trim +whitespace+ string)) + +(defun string-left-trim-whitespace (string) + (string-left-trim +whitespace+ string)) + +(defun split-string-at-char (string separator &key escape skip-empty) + "Split STRING at SEPARATORs and return a list of the substrings. If +SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is +not nil then split at SEPARATOR only if it's not preceded by ESCAPE." + (declare (type string string) (type character separator)) + (labels ((next-separator (beg) + (be pos (position separator string :start beg) + (if (and escape + pos + (plusp pos) + (char= escape (char string (1- pos)))) + (next-separator (1+ pos)) + pos))) + (parse (beg) + (cond ((< beg (length string)) + (let* ((end (next-separator beg)) + (substring (subseq string beg end))) + (cond ((and skip-empty (string= "" substring)) + (parse (1+ end))) + ((not end) + (list substring)) + (t + (cons substring (parse (1+ end))))))) + (skip-empty + '()) + (t + (list ""))))) + (parse 0))) + +(defun s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(defun string-concat (list &optional (separator "")) + "Concatenate the strings in LIST interposing SEPARATOR (default +nothing) between them." + (reduce #'(lambda (&rest args) + (if args + (s+ (car args) separator (cadr args)) + "")) + list)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (be prefix-length (length prefix) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +;; QUEUE + +(defstruct queue + first + last) + +(defgeneric queue-append (queue objects)) +(defgeneric queue-pop (queue)) +(defgeneric queue-empty-p (queue)) + +(defmethod queue-append ((queue queue) (objects list)) + (cond ((null (queue-first queue)) + (setf (queue-first queue) objects + (queue-last queue) (last objects))) + (t + (setf (cdr (queue-last queue)) objects + (queue-last queue) (last objects)))) + queue) + +(defmethod queue-append ((queue queue) object) + (queue-append queue (list object))) + +(defmethod queue-pop ((queue queue)) + (prog1 (car (queue-first queue)) + (setf (queue-first queue) (cdr (queue-first queue))))) + +(defmethod queue-empty-p ((queue queue)) + (null (queue-first queue))) + +;; STREAMS + +(defmacro save-file-excursion ((stream &optional position) &body forms) + "Execute FORMS returning, on exit, STREAM to the position it was +before FORMS. Optionally POSITION can be set to the starting offset." + (unless position + (setf position (gensym))) + `(be ,position (file-position ,stream) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (in pathname + :element-type element-type + :if-does-not-exist (unless (eq :value if-does-not-exist) + :error)) + (if in + (be seq (make-array (file-length in) :element-type element-type) + (read-sequence seq in) + seq) + default))) + +;; FILES + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +(defstruct (unix-file-stat (:conc-name stat-)) + device + inode + links + atime + mtime + ctime + size + blksize + blocks + uid + gid + mode) + +(defun unix-stat (pathname) + ;; this could be different depending on the unix systems + (multiple-value-bind (ok? device inode mode links uid gid rdev + size atime mtime ctime + blksize blocks) + (#+cmu unix:unix-lstat + #+sbcl sb-unix:unix-lstat + ;; TODO(sterni): ECL, CCL + (if (stringp pathname) + pathname + (native-namestring pathname))) + (declare (ignore rdev)) + (when ok? + (make-unix-file-stat :device device + :inode inode + :links links + :atime atime + :mtime mtime + :ctime ctime + :size size + :blksize blksize + :blocks blocks + :uid uid + :gid gid + :mode mode)))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + (stat-size (unix-stat pathname))) + +;; LAZY + +(defstruct promise + procedure + value) + +(defmacro lazy (form) + `(make-promise :procedure #'(lambda () ,form))) + +(defun forced-p (promise) + (null (promise-procedure promise))) + +(defun force (promise) + (if (forced-p promise) + (promise-value promise) + (prog1 (setf (promise-value promise) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) + +(defmacro deflazy (name value &optional documentation) + `(defparameter ,name (lazy ,value) + ,@(when documentation + (list documentation)))) + +;; FIXNUMS + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +;; TIME + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defvar +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp index 5639aab23641..eec7f87dfa19 100644 --- a/third_party/lisp/mime4cl/mime.lisp +++ b/third_party/lisp/mime4cl/mime.lisp @@ -702,7 +702,7 @@ body." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) +(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) "List of known content encodings.") (defun keywordify-encoding (string) diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp index 5586bdc390e5..31cd85d54e24 100644 --- a/third_party/lisp/mime4cl/package.lisp +++ b/third_party/lisp/mime4cl/package.lisp @@ -23,13 +23,7 @@ (defpackage :mime4cl (:nicknames :mime) - (:use :common-lisp :npg :sclf :trivial-gray-streams) - ;; this is stuff that comes from SCLF and clashes with CMUCL's EXT - ;; package - (:shadowing-import-from :sclf - #:process-wait - #:process-alive-p - #:run-program) + (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams) (:import-from :babel :octets-to-string) (:import-from :babel-encodings :get-character-encoding) (:export #:*lazy-mime-decode* diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp index 5e8d43a7d4f8..4ff89d5eacb0 100644 --- a/third_party/lisp/mime4cl/test/endec.lisp +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -139,9 +139,9 @@ line") (declare (optimize (speed 3) (debug 0) (safety 0)) (type fixnum megs)) (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) - (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) + (let ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) :type "encoded-data"))) - (sclf:with-temp-file (tmp nil :direction :io) + (with-temp-file (tmp nil :direction :io) (let* ((meg (* 1024 1024)) (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) (encoder-class (ecase decoder-class diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp index 6da1fc8fa29f..965680448fe4 100644 --- a/third_party/lisp/mime4cl/test/package.lisp +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -23,5 +23,5 @@ (defpackage :mime4cl-tests (:use :common-lisp - :rtest :mime4cl) + :rtest :mime4cl :mime4cl-ex-sclf) (:export)) diff --git a/third_party/lisp/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp new file mode 100644 index 000000000000..3e6765806c4e --- /dev/null +++ b/third_party/lisp/mime4cl/test/temp-file.lisp @@ -0,0 +1,72 @@ +;;; temp-file.lisp --- temporary file creation + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl +;;; +;;; Code taken from SCLF + +#+cmu (ext:file-comment "$Module: temp-file.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defvar *tmp-file-defaults* #P"/tmp/") + +(defun temp-file-name (&optional (default *tmp-file-defaults*)) + "Create a random pathname based on DEFAULT. No effort is made +to make sure that the returned pathname doesn't identify an +already existing file. If missing DEFAULT defaults to +*TMP-FILE-DEFAULTS*." + (make-pathname :defaults default + :name (format nil "~36R" (random #.(expt 36 10))))) + +(defun open-temp-file (&optional default-pathname &rest open-args) + "Open a new temporary file and return a stream to it. This function +makes sure the pathname of the temporary file is unique. OPEN-ARGS +are arguments passed verbatim to OPEN. If OPEN-ARGS specify +the :DIRECTION it should be either :OUTPUT (default) or :IO; +any other value causes an error. If DEFAULT-PATHNAME is specified and +not NIL it's used as defaults to produce the pathname of the temporary +file, otherwise *TMP-FILE-DEFAULTS* is used." + (unless default-pathname + (setf default-pathname *tmp-file-defaults*)) + ;; if :DIRECTION is specified check that it's compatible with the + ;; purpose of this function, otherwise make it default to :OUTPUT + (aif (getf open-args :direction) + (unless (member it '(:output :io)) + (error "Can't create temporary file with open direction ~A." it)) + (setf open-args (append '(:direction :output) + open-args))) + (do* ((name #1=(temp-file-name default-pathname) #1#) + (stream #2=(apply #'open name + :if-exists nil + :if-does-not-exist :create + open-args) #2#)) + (stream stream))) + +(defmacro with-temp-file ((stream &rest open-temp-args) &body body) + "Execute BODY within a dynamic extent where STREAM is bound to +a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are +passed verbatim to OPEN-TEMP-FILE." + `(be ,stream (open-temp-file ,@open-temp-args) + (unwind-protect + (progn ,@body) + (close ,stream) + ;; body may decide to rename the file so we must ignore the errors + (ignore-errors + (delete-file (pathname ,stream)))))) diff --git a/third_party/lisp/sclf/.skip-subtree b/third_party/lisp/sclf/.skip-subtree deleted file mode 100644 index 5051f60d6b86..000000000000 --- a/third_party/lisp/sclf/.skip-subtree +++ /dev/null @@ -1 +0,0 @@ -prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/sclf/OWNERS b/third_party/lisp/sclf/OWNERS deleted file mode 100644 index f16dd105d761..000000000000 --- a/third_party/lisp/sclf/OWNERS +++ /dev/null @@ -1,3 +0,0 @@ -inherited: true -owners: - - sterni diff --git a/third_party/lisp/sclf/README b/third_party/lisp/sclf/README deleted file mode 100644 index 2a1c2c3c5c1c..000000000000 --- a/third_party/lisp/sclf/README +++ /dev/null @@ -1,6 +0,0 @@ -SCLF has originally been written by Walter C. Pelissero and vendored -into depot since it is a dependency of mime4cl. Upstream and depot version -may diverge. - -Upstream Website: http://wcp.sdf-eu.org/software/#sclf -Vendored Tarball: http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz diff --git a/third_party/lisp/sclf/default.nix b/third_party/lisp/sclf/default.nix deleted file mode 100644 index fb07f8f764e5..000000000000 --- a/third_party/lisp/sclf/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -# Copyright (C) 2021 by the TVL Authors -# SPDX-License-Identifier: LGPL-2.1-or-later -{ depot, pkgs, ... }: - -depot.nix.buildLisp.library { - name = "sclf"; - - deps = [ - (depot.nix.buildLisp.bundled "sb-posix") - ]; - - srcs = [ - ./package.lisp - ./sclf.lisp - ./sysproc.lisp - ./lazy.lisp - ./time.lisp - ./directory.lisp - ./serial.lisp - ./mp/sbcl.lisp - ]; - - # TODO(sterni): implement OS interaction for ECL and CCL - brokenOn = [ - "ecl" - "ccl" - ]; -} diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp deleted file mode 100644 index 3e479c4ac279..000000000000 --- a/third_party/lisp/sclf/directory.lisp +++ /dev/null @@ -1,404 +0,0 @@ -;;; directory.lisp --- filesystem directory access - -;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero -;;; Copyright (C) 2021 by the TVL Authors - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: sclf - -#+cmu (ext:file-comment "$Module: directory.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - - -(cl:in-package :sclf) - -(defun pathname-as-directory (pathname) - "Converts PATHNAME to directory form and return it." - (setf pathname (pathname pathname)) - (if (pathname-name pathname) - (make-pathname :directory (append (or (pathname-directory pathname) - '(:relative)) - (list (file-namestring pathname))) - :name nil - :type nil - :defaults pathname) - pathname)) - -(defun d+ (path &rest rest) - "Concatenate directory pathname parts and return a pathname." - (make-pathname :defaults path - :directory (append (pathname-directory path) rest))) - -(defun delete-directory (pathname) - "Remove directory PATHNAME. Return PATHNAME." - #+cmu (multiple-value-bind (done errno) - (unix:unix-rmdir (namestring pathname)) - (unless done - (error "Unable to delete directory ~A (errno=~A)" - pathname errno))) - #+sbcl (sb-posix:rmdir pathname) - #+lispworks (lw:delete-directory pathname) - #-(or cmu sbcl) - (error "DELETE-DIRECTORY not implemented for you lisp system.") - pathname) - -(defun list-directory (pathname &key truenamep) - "List content of directory PATHNAME. If TRUENAMEP is true don't try -to follow symbolic links." - #-(or sbcl cmu) (declare (ignore truenamep)) - (let (#+cmu (lisp::*ignore-wildcards* t)) - (directory (make-pathname :defaults (pathname-as-directory pathname) - :name :wild - :type :wild - :version :wild) - #+cmu :truenamep #+cmu truenamep - #+sbcl :resolve-symlinks #+sbcl truenamep))) - -(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first) - "Call PROC on all pathnames under ROOT-PATHNAME, both files and -directories. Unless TRUENAMEP is true, this function doesn't try -to lookup the truename of files, as finding the truename may be a -superfluous and noxious activity expecially when you expect -broken symbolic links in your filesystem." - (check-type root-pathname pathname) - (check-type proc (or function symbol)) - (check-type test (or function symbol null)) - (labels ((ls (dir) - (declare (type pathname dir)) - (list-directory dir :truenamep truenamep)) - (traverse? (file) - (declare (type pathname file)) - (and (not (pathname-name file)) - (or truenamep - (not (symbolic-link-p file))) - (or (not test) - (funcall test file)))) - (traverse-pre-order (dir) - (declare (type pathname dir)) - (loop - for file in (ls dir) - do (funcall proc file) - when (traverse? file) - do (traverse-pre-order file))) - (traverse-post-order (dir) - (declare (type pathname dir)) - (loop - for file in (ls dir) - when (traverse? file) - do (traverse-post-order file) - do (funcall proc file)))) - (if depth-first - (traverse-post-order root-pathname) - (traverse-pre-order root-pathname)) - (values))) - -(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body) - "Call TRAVERSE-DIRECTORY-TREE with BODY es procedure." - `(traverse-directory-tree ,root-pathname - #'(lambda (,file) - ,@body) - :truenamep ,truenamep - :test ,test - :depth-first ,depth-first)) - -(defun empty-directory-p (pathname) - (and (directory-p pathname) - (endp (list-directory pathname)))) - -(defun remove-empty-directories (root) - (do-directory-tree (pathname root :depth-first t) - (when (empty-directory-p pathname) - (delete-directory pathname)))) - -(defun map-directory-tree (pathname function) - "Apply FUNCTION to every file in a directory tree starting from -PATHNAME. Return the list of results." - (be return-list '() - (do-directory-tree (directory-entry pathname) - (push (funcall function directory-entry) return-list)) - (nreverse return-list))) - -(defun find-files (root-pathname matcher-function &key truenamep) - "In the directory tree rooted at ROOT-PATHNAME, find files that -when the pathname is applied to MATCHER-FUNCTION will return -true. Return the list of files found. Unless TRUENAMEP is true -this function doesn't try to lookup the truename of -files. Finding the truename may be a superfluous and noxious -activity expecially when you expect broken symbolic links in your -filesystem. (This may not apply to your particular lisp -system.)" - (be files '() - (do-directory-tree (file root-pathname :truenamep truenamep) - (when (funcall matcher-function file) - (push file files))) - (nreverse files))) - -(defun delete-directory-tree (pathname) - "Recursively delete PATHNAME and all the directory structure below -it. - -WARNING: depending on the way the DIRECTORY function is implemented on -your Lisp system this function may follow Unix symbolic links and thus -delete files outside the PATHNAME hierarchy. Check this before using -this function in your programs." - (if (pathname-name pathname) - (delete-file pathname) - (progn - (dolist (file (list-directory pathname)) - (delete-directory-tree file)) - (delete-directory pathname)))) - -(defun make-directory (pathname &optional (mode #o777)) - "Create a new directory in the filesystem. Permissions MODE -will be assigned to it. Return PATHNAME." - #+cmu (multiple-value-bind (done errno) - (unix:unix-mkdir (native-namestring pathname) mode) - (unless done - (error "Unable to create directory ~A (errno=~A)." pathname errno))) - #+sbcl (sb-posix:mkdir pathname mode) - #-(or cmu sbcl) - (error "MAKE-DIRECTORY is not implemented for this Lisp system.") - pathname) - -;; At least on SBCL/CMUCL + Unix + NFS this function is faster than -;; ENSURE-DIRECTORIES-EXIST, because it doesn't check all the pathname -;; components starting from the root; it proceeds from the leaf and -;; crawls the directory tree upward only if necessary." -(defun ensure-directory (pathname &key verbose (mode #o777)) - "Just like ENSURE-DIRECTORIES-EXIST but, in some situations, -it's faster." - (labels ((ensure (path) - (unless (probe-file path) - (be* tail (last (pathname-directory path) 2) - last (cdr tail) - (setf (cdr tail) nil) - (unwind-protect - (ensure path) - (setf (cdr tail) last)) - (make-directory path mode) - (when verbose - (format t "Created ~S~%" path)))))) - (ensure (make-pathname :defaults pathname - :name nil :type nil - :version nil)))) - -(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777)) - "Create a new directory and return its pathname. -If DEFAULT-PATHNAME is specified and not NIL it's used as -defaults to produce the pathname of the directory. Return the -pathname of the temporary directory." - (loop - for name = (pathname-as-directory (temp-file-name default-pathname)) - when (ignore-errors (make-directory name mode)) - return name)) - -(defmacro with-temp-directory ((path &rest make-temp-directory-args) &body body) - "Execute BODY with PATH bound to the pathname of a new unique -temporary directory. On exit of BODY the directory tree starting from -PATH will be automatically removed from the filesystem. Return what -BODY returns. BODY is _not_ executed within the PATH directory; the -working directory is never changed." - `(be ,path (make-temp-directory ,@make-temp-directory-args) - (unwind-protect - (progn ,@body) - (delete-directory-tree ,path)))) - -(defun current-directory () - "Return the pathname of the current directory." - (truename (make-pathname :directory '(:relative)))) - -(defun ensure-home-translations () - "Ensure that the logical pathname translations for the host \"home\" -are defined." - ;; CMUCL already defines a HOME translation of its own and gets - ;; angry if we try to redefine it - #-cmu - (be home (user-homedir-pathname) - ;; we should discard and replace whatever has been defined in any - ;; rc file during compilation - (setf (logical-pathname-translations "home") - (list - (list "**;*.*.*" - (make-pathname :defaults home - :directory (append (pathname-directory home) - '(:wild-inferiors)) - :name :wild - :type :wild)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - #+sbcl (sb-ext:parse-native-namestring string host defaults - :start start - :end end - :junk-allowed junk-allowed) - #-sbcl (let (#+cmu(lisp::*ignore-wildcards* t)) - (parse-namestring string host defaults - :start start - :end end - :junk-allowed junk-allowed))) - -(defun native-namestring (pathname) - #+sbcl (sb-ext:native-namestring pathname) - #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) - (namestring pathname))) - -(defun native-file-namestring (pathname) - #+sbcl (sb-ext:native-namestring - (make-pathname :name (pathname-name pathname) - :type (pathname-type pathname))) - #+cmu (be lisp::*ignore-wildcards* t - (file-namestring pathname))) - -(defun native-pathname (thing) - #+sbcl (sb-ext:native-pathname thing) - #+cmu (be lisp::*ignore-wildcards* t - (pathname thing))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun bits-set-p (x bits) - (= (logand x bits) - bits)) - -(defun directory-p (pathname) - "Return true if PATHNAME names a directory on the filesystem." - #-clisp (awhen (unix-stat (native-namestring pathname)) - (bits-set-p (stat-mode it) - #+sbcl sb-posix:s-ifdir - #+cmu unix:s-ifdir)) - #+clisp (ext:probe-directory (pathname-as-directory pathname))) - -(defun regular-file-p (pathname) - "Return true if PATHNAME names a regular file on the filesystem." - #-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file") - (awhen (unix-stat (native-namestring pathname)) - (bits-set-p (stat-mode it) - #+sbcl sb-posix:s-ifreg - #+cmu unix:s-ifreg))) - -(defun file-readable-p (pathname) - #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok) - #+cmu (unix:unix-access (native-namestring pathname) unix:r_ok) - #-(or sbcl cmu) (error "don't know how to check whether a file might be readable")) - -(defun file-writable-p (pathname) - #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:w_ok) - #+cmu (unix:unix-access (native-namestring pathname) unix:w_ok) - #-(or sbcl cmu) (error "don't know how to check whether a file might be writable")) - -(defun file-executable-p (pathname) - #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:x_ok) - #+cmu (unix:unix-access (native-namestring pathname) unix:x_ok) - #-(or sbcl cmu) (error "don't know how to check whether a file might be executable")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct (unix-file-stat (:conc-name stat-)) - device - inode - links - atime - mtime - ctime - size - blksize - blocks - uid - gid - mode) - -(defun unix-stat (pathname) - ;; this could be different depending on the unix systems - (multiple-value-bind (ok? device inode mode links uid gid rdev - size atime mtime ctime - blksize blocks) - (#+cmu unix:unix-lstat - #+sbcl sb-unix:unix-lstat - (if (stringp pathname) - pathname - (native-namestring pathname))) - (declare (ignore rdev)) - (when ok? - (make-unix-file-stat :device device - :inode inode - :links links - :atime atime - :mtime mtime - :ctime ctime - :size size - :blksize blksize - :blocks blocks - :uid uid - :gid gid - :mode mode)))) - -(defun stat-modification-time (stat) - "Return the modification time of the STAT structure as Lisp -Universal Time, which is not the same as the Unix time." - (unix->universal-time (stat-mtime stat))) - -(defun stat-creation-time (stat) - "Return the creation time of the STAT structure as Lisp -Universal Time, which is not the same as the Unix time." - (unix->universal-time (stat-ctime stat))) - -(defun file-modification-time (file) - "Return the modification time of FILE as Lisp Universal Time, which -is not the same as the Unix time." - (awhen (unix-stat file) - (stat-modification-time it))) - -(defun file-creation-time (file) - "Return the creation time of FILE as Lisp Universal Time, which -is not the same as the Unix time." - (awhen (unix-stat file) - (stat-creation-time it))) - -(defun read-symbolic-link (symlink) - "Return the pathname the SYMLINK points to. That is, it's -contents." - #+sbcl (sb-posix:readlink (native-namestring symlink)) - #+cmu (unix:unix-readlink (native-namestring symlink))) - -;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix -;; allows to get to know the file size without being able to open a -;; file; just ask politely. -(defun file-size (pathname) - (stat-size (unix-stat pathname))) - -(defun symbolic-link-p (pathname) - #-(or sbcl cmu) (error "don't know hot to test for symbolic links.") - (aand (unix-stat pathname) - (bits-set-p (stat-mode it) - #+sbcl sb-posix:s-iflnk - #+cmu unix:s-iflnk))) - -(defun broken-link-p (pathname) - (when (symbolic-link-p pathname) - #+cmu (not (ignore-errors (truename pathname))) - ;; On a broken symlink SBCL returns the link path without resolving - ;; the link itself. De gustibus non est disputandum. - #+sbcl (equalp pathname (probe-file pathname)))) - -(defun move-file (old new) - "Just like RENAME-FILE, but doesn't carry on to NEW file the type of -OLD file, if NEW doesn't specify one. It does what most people would -expect from a rename function, which RENAME-FILE doesn't do. -So (MOVE-FILE \"foo.bar\" \"foo\") does rename foo.bar to foo, losing -the \"bar\" type; RENAME-FILE wouldn't allow you that." - #+sbcl (sb-posix:rename (native-namestring old) (native-namestring new)) - #+cmu (unix:unix-rename (native-namestring old) (native-namestring new))) diff --git a/third_party/lisp/sclf/lazy.lisp b/third_party/lisp/sclf/lazy.lisp deleted file mode 100644 index 34bae82ebb64..000000000000 --- a/third_party/lisp/sclf/lazy.lisp +++ /dev/null @@ -1,134 +0,0 @@ -;;; lazy.lisp --- lazy primitives - -;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: sclf - -#+cmu (ext:file-comment "$Module: lazy.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Lazy primitives -;;; - -(in-package :sclf) - -(defstruct promise - procedure - value) - -(defmacro lazy (form) - `(make-promise :procedure #'(lambda () ,form))) - -(defun forced-p (promise) - (null (promise-procedure promise))) - -(defun force (promise) - (if (forced-p promise) - (promise-value promise) - (prog1 (setf (promise-value promise) - (funcall (promise-procedure promise))) - (setf (promise-procedure promise) nil)))) - -(defmacro deflazy (name value &optional documentation) - `(defparameter ,name (lazy ,value) - ,@(when documentation - (list documentation)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass lazy-metaclass (standard-class) - () - (:documentation "Metaclass for object having lazy slots. Lazy slots -should be specified with the :LAZY keyword which must be a function of -one argument. If required this function will be called once to get -the value to memoize in the slot. Lazy slots can also be set/read as -any other.")) - -(defmethod validate-superclass ((class lazy-metaclass) (super standard-class)) - "Lazy classes may inherit from ordinary classes." - (declare (ignore class super)) - t) - -(defmethod validate-superclass ((class standard-class) (super lazy-metaclass)) - "Ordinary classes may inherit from lazy classes." - (declare (ignore class super)) - t) - -(defclass lazy-slot-mixin () - ((lazy-function :initarg :lazy - :reader lazy-slot-function - :initform nil)) - (:documentation - "Slot for LAZY-METACLASS classes. Lazy slots must be declared with -the argument :LAZY which must be a function accepting the object -instance as argument.")) - -(defclass lazy-direct-slot-definition (lazy-slot-mixin standard-direct-slot-definition) - ()) - -(defclass lazy-effective-slot-definition (lazy-slot-mixin standard-effective-slot-definition) - ()) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod direct-slot-definition-class ((class lazy-metaclass) &rest initargs) - (if (getf initargs :lazy nil) - (find-class 'lazy-direct-slot-definition) - (call-next-method))) - -(defmethod effective-slot-definition-class ((class lazy-metaclass) &rest initargs) - (if (getf initargs :lazy nil) - (find-class 'lazy-effective-slot-definition) - (call-next-method))) - -(defmethod compute-effective-slot-definition-initargs ((class lazy-metaclass) direct-slots) - (let ((ds (car direct-slots))) - (if (typep ds 'lazy-direct-slot-definition) - (let ((form (lazy-slot-function ds)) - (args (call-next-method))) - (when (or (getf args :initarg) - (getf args :initform)) - (error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds)) - (list* :lazy - (cond ((and (listp form) - (eq 'lambda (car form))) - (compile nil form)) - ((symbolp form) - form) - (t (compile nil `(lambda (self) - (declare (ignorable self)) - ,form)))) - args)) - (call-next-method)))) - -(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin)) - (declare (ignore class)) - ;; If the slot is unbound, call the lazy function passing the - ;; instance and memoize the value in the slot. - (unless (slot-boundp-using-class class instance slot) - (setf (slot-value-using-class class instance slot) - (funcall (lazy-slot-function slot) instance))) - (call-next-method)) - -(defun reset-lazy-slots (object) - "Unbind all the lazy slots in OBJECT so that they will be -re-evaluated next time their value is requested again." - (be* class (class-of object) - (dolist (slot (class-slots class)) - (when (typep slot 'lazy-effective-slot-definition) - (slot-makunbound object (slot-definition-name slot)))))) \ No newline at end of file diff --git a/third_party/lisp/sclf/mp/README b/third_party/lisp/sclf/mp/README deleted file mode 100644 index a0732c029453..000000000000 --- a/third_party/lisp/sclf/mp/README +++ /dev/null @@ -1,6 +0,0 @@ -This directory contains an uniforming layer for multiprocessing in the -style supported by Allegro Common Lisp and CMUCL. Almost nothing of -this has been written by me. It's mostly the work of Gilbert Baumann -(unk6@rz.uni-karlsruhe.de) and I've shamelessly lifted it from McCLIM. -The copyright disclaimer in this code is compatible with the one of -SCLF, so I believe there should be no legal issues. diff --git a/third_party/lisp/sclf/mp/cmu.lisp b/third_party/lisp/sclf/mp/cmu.lisp deleted file mode 100644 index 1bdbba79896f..000000000000 --- a/third_party/lisp/sclf/mp/cmu.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;; -;;; Code freely lifted from various places with compatible license -;;; terms. Most of this code is copyright Gilbert Baumann -;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter -;;; C. Pelissero <walter@pelissero.de>. -;;; - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Library General Public -;;; License as published by the Free Software Foundation; either -;;; version 2 of the License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Library General Public License for more details. -;;; -;;; You should have received a copy of the GNU Library General Public -;;; License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307 USA. - -(in-package :sclf) - -(defun make-lock (&optional name) - (mp:make-lock name)) - -(defun make-recursive-lock (&optional name) - (mp:make-lock name :kind :recursive)) - -(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms) - `(mp:with-lock-held (,lock ,(or whostate "Lock Wait") - :wait wait - ,@(when timeout (list :timeout timeout))) - ,@forms)) - -(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms) - `(mp:with-lock-held (,lock - ,@(when wait (list :wait wait)) - ,@(when timeout (list :timeout timeout))) - ,@forms)) - -(defstruct condition-variable - (lock (make-lock "condition variable")) - (value nil) - (process-queue nil)) - -(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp - #+i486 (kernel:%instance-set-conditional - lock 2 mp:*current-process* nil) - #-i486 (when (eq (lock-process lock) mp:*current-process*) - (setf (lock-process lock) nil))) - -(defun condition-wait (cv lock &optional timeout) - (declare (ignore timeout)) ;For now - (loop - (let ((cv-lock (condition-variable-lock cv))) - (with-lock-held (cv-lock) - (when (condition-variable-value cv) - (setf (condition-variable-value cv) nil) - (return-from condition-wait t)) - (setf (condition-variable-process-queue cv) - (nconc (condition-variable-process-queue cv) - (list mp:*current-process*))) - (%release-lock lock)) - (mp:process-add-arrest-reason mp:*current-process* cv) - (let ((cv-val nil)) - (with-lock-held (cv-lock) - (setq cv-val (condition-variable-value cv)) - (when cv-val - (setf (condition-variable-value cv) nil))) - (when cv-val - (mp::lock-wait lock "waiting for condition variable lock") - (return-from condition-wait t)))))) - -(defun condition-notify (cv) - (with-lock-held ((condition-variable-lock cv)) - (let ((proc (pop (condition-variable-process-queue cv)))) - ;; The waiting process may have released the CV lock but not - ;; suspended itself yet - (when proc - (loop - for activep = (mp:process-active-p proc) - while activep - do (mp:process-yield)) - (setf (condition-variable-value cv) t) - (mp:process-revoke-arrest-reason proc cv)))) - ;; Give the other process a chance - (mp:process-yield)) - -(defun process-execute (process function) - (mp:process-preset process function) - ;; For some obscure reason process-preset doesn't make the process - ;; runnable. I'm sure it's me who didn't understand how - ;; multiprocessing works under CMUCL, despite the vast documentation - ;; available. - (mp:enable-process process) - (mp:process-add-run-reason process :enable)) - -(defun destroy-process (process) - ;; silnetly ignore a process that is trying to destroy itself - (unless (eq (mp:current-process) - process) - (mp:destroy-process process))) - -(defun restart-process (process) - (mp:restart-process process) - (mp:enable-process process) - (mp:process-add-run-reason process :enable)) - -(defun process-alive-p (process) - (mp:process-alive-p process)) - -(defun process-join (process) - (error "PROCESS-JOIN not support under CMUCL.")) diff --git a/third_party/lisp/sclf/mp/sbcl.lisp b/third_party/lisp/sclf/mp/sbcl.lisp deleted file mode 100644 index a2cf497ff9bf..000000000000 --- a/third_party/lisp/sclf/mp/sbcl.lisp +++ /dev/null @@ -1,235 +0,0 @@ -;;; -;;; Code freely lifted from various places with compatible license -;;; terms. Most of this code is copyright Daniel Barlow -;;; <dan@metacircles.com> or Gilbert Baumann -;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter -;;; C. Pelissero <walter@pelissero.de>. -;;; - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Library General Public -;;; License as published by the Free Software Foundation; either -;;; version 2 of the License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Library General Public License for more details. -;;; -;;; You should have received a copy of the GNU Library General Public -;;; License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;; Boston, MA 02111-1307 USA. - -(in-package :sclf) - -(defstruct (process - (:constructor %make-process) - (:predicate processp)) - name - state - whostate - function - thread) - -(defvar *current-process* - (%make-process - :name "initial process" :function nil - :thread - #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - sb-thread:*current-thread* - #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - (sb-thread:current-thread-id))) - -(defvar *all-processes* (list *current-process*)) - -(defvar *all-processes-lock* - (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) - -;; we implement disable-process by making the disablee attempt to lock -;; *permanent-queue*, which is already locked because we locked it -;; here. enable-process just interrupts the lock attempt. - -(defmacro get-mutex (mutex &optional (wait t)) - `( - #+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) - sb-thread:grab-mutex - #-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or)) - sb-thread:get-mutex - ,mutex :waitp ,wait)) - -(defvar *permanent-queue* - (sb-thread:make-mutex :name "Lock for disabled threads")) -(unless (sb-thread:mutex-owner *permanent-queue*) - (get-mutex *permanent-queue* nil)) - -(defun make-process (function &key name) - (let ((p (%make-process :name name - :function function))) - (sb-thread:with-mutex (*all-processes-lock*) - (pushnew p *all-processes*)) - (restart-process p))) - -(defun process-kill-thread (process) - (let ((thread (process-thread process))) - (when (and thread - (sb-thread:thread-alive-p thread)) - (assert (not (eq thread sb-thread:*current-thread*))) - (sb-thread:terminate-thread thread) - ;; Wait until all the clean-up forms are done. - (sb-thread:join-thread thread :default nil)) - (setf (process-thread process) nil))) - -(defun process-join (process) - (sb-thread:join-thread (process-thread process))) - -(defun restart-process (p) - (labels ((boing () - (let ((*current-process* p) - (function (process-function p))) - (when function - (funcall function))))) - (process-kill-thread p) - (when (setf (process-thread p) - (sb-thread:make-thread #'boing :name (process-name p))) - p))) - -(defun destroy-process (process) - (sb-thread:with-mutex (*all-processes-lock*) - (setf *all-processes* (delete process *all-processes*))) - (process-kill-thread process)) - -(defun current-process () - *current-process*) - -(defun all-processes () - ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value - ;; while that delete is executing, we could end up with nonsense. - ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS). - (sb-thread:with-mutex (*all-processes-lock*) - *all-processes*)) - -(defun process-yield () - (sb-thread:thread-yield)) - -(defun process-wait (reason predicate) - (let ((old-state (process-whostate *current-process*))) - (unwind-protect - (progn - (setf old-state (process-whostate *current-process*) - (process-whostate *current-process*) reason) - (until (funcall predicate) - (process-yield))) - (setf (process-whostate *current-process*) old-state)))) - -(defun process-wait-with-timeout (reason timeout predicate) - (let ((old-state (process-whostate *current-process*)) - (end-time (+ (get-universal-time) timeout))) - (unwind-protect - (progn - (setf old-state (process-whostate *current-process*) - (process-whostate *current-process*) reason) - (loop - for result = (funcall predicate) - until (or result - (> (get-universal-time) end-time)) - do (process-yield) - finally (return result))) - (setf (process-whostate *current-process*) old-state)))) - -(defun process-interrupt (process function) - (sb-thread:interrupt-thread (process-thread process) function)) - -(defun disable-process (process) - (sb-thread:interrupt-thread - (process-thread process) - (lambda () - (catch 'interrupted-wait (get-mutex *permanent-queue*))))) - -(defun enable-process (process) - (sb-thread:interrupt-thread - (process-thread process) (lambda () (throw 'interrupted-wait nil)))) - -(defmacro without-scheduling (&body body) - (declare (ignore body)) - (error "WITHOUT-SCHEDULING is not supported on this platform.")) - -(defparameter *atomic-lock* - (sb-thread:make-mutex :name "atomic incf/decf")) - -(defmacro atomic-incf (place) - `(sb-thread:with-mutex (*atomic-lock*) - (incf ,place))) - -(defmacro atomic-decf (place) - `(sb-thread:with-mutex (*atomic-lock*) - (decf ,place))) - -;;; 32.3 Locks - -(defun make-lock (&optional name) - (sb-thread:make-mutex :name name)) - -(defmacro with-lock-held ((place &key state (wait t) timeout) &body body) - (declare (ignore timeout)) - (let ((old-state (gensym "OLD-STATE"))) - `(sb-thread:with-mutex (,place :wait-p ,wait) - (let (,old-state) - (unwind-protect - (progn - (when ,state - (setf ,old-state (process-state *current-process*)) - (setf (process-state *current-process*) ,state)) - ,@body) - (setf (process-state *current-process*) ,old-state)))))) - - -(defun make-recursive-lock (&optional name) - (sb-thread:make-mutex :name name)) - -(defmacro with-recursive-lock-held ((place &optional state (wait t) timeout) &body body) - (declare (ignore wait timeout)) - (let ((old-state (gensym "OLD-STATE"))) - `(sb-thread:with-recursive-lock (,place) - (let (,old-state) - (unwind-protect - (progn - (when ,state - (setf ,old-state (process-state *current-process*)) - (setf (process-state *current-process*) ,state)) - ,@body) - (setf (process-state *current-process*) ,old-state)))))) - -(defun make-condition-variable () (sb-thread:make-waitqueue)) - -(defun condition-wait (cv lock &optional timeout) - (if timeout - (handler-case - (sb-ext:with-timeout timeout - (sb-thread:condition-wait cv lock) - t) - (sb-ext:timeout (c) - (declare (ignore c)) - nil)) - (progn (sb-thread:condition-wait cv lock) t))) - -(defun condition-notify (cv) - (sb-thread:condition-notify cv)) - - -(defvar *process-plists* (make-hash-table) - "Hash table mapping processes to a property list. This is used by -PROCESS-PLIST.") - -(defun process-property-list (process) - (gethash process *process-plists*)) - -(defun (setf process-property-list) (value process) - (setf (gethash process *process-plists*) value)) - -(defun process-execute (process function) - (setf (process-function process) function) - (restart-process process)) - -(defun process-alive-p (process) - (sb-thread:thread-alive-p (process-thread process))) diff --git a/third_party/lisp/sclf/package.lisp b/third_party/lisp/sclf/package.lisp deleted file mode 100644 index 565ab301c7e8..000000000000 --- a/third_party/lisp/sclf/package.lisp +++ /dev/null @@ -1,258 +0,0 @@ -;;; package.lisp --- packages description - -;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero -;;; Copyright (C) 2021 by the TVL Authors - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: sclf - -#+cmu (ext:file-comment "$Module: package.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -(in-package :cl-user) - -(defpackage :sclf - (:use :common-lisp - ;; we need the MOP for lazy.lisp and serial.lisp - #+cmu :pcl - #+sbcl :sb-mop) - ;; Don't know why but compute-effective-slot-definition-initargs is - ;; internal in both CMUCL and SBCL - (:import-from #+cmu"PCL" #+sbcl"SB-PCL" - #-(or cmu sbcl) "CLOS" - "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS") - #+cmu (:import-from :mp - #:make-process - #:current-process - #:all-processes - #:processp - #:process-name - #:process-state - #:process-whostate - #:process-wait - #:process-wait-with-timeout - #:process-yield - #:process-interrupt - #:disable-process - #:enable-process - #:without-scheduling - #:atomic-incf - #:atomic-decf - #:process-property-list) - (:export #:be #:be* - #:defconst - #:with-gensyms - #:d+ - #:s+ - #:f++ - #:list->string - #:string-starts-with #:string-ends-with - #:aif #:awhen #:acond #:aand #:acase #:it - #:+whitespace+ - #:string-trim-whitespace - #:string-right-trim-whitespace - #:string-left-trim-whitespace - #:whitespace-p #:seq-whitespace-p - #:not-empty - #:position-any - #:+month-names+ - #:find-any - #:split-at - #:split-string-at-char - #:week-day->string - #:month->string - #:month-string->number - #:add-months #:add-days - #:read-whole-stream - #:read-file #:write-file #:read-lines - #:read-from-file #:write-to-file - #:string-concat - #:gcase - #:string-truncate - #:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots - #:copy-stream #:copy-file - #:symlink-file - #:keywordify - #:until - #:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year - #:beginning-of-week #:end-of-week - #:next-week-day #:next-monday #:full-weeks-in-span - #:beginning-of-first-week #:end-of-last-week - #:beginning-of-month #:end-of-month - #:locate-system-program - #:*tmp-file-defaults* - #:temp-file-name - #:open-temp-file - #:with-temp-file - #:file-size - #:getenv - #:with-system-environment - #:time-string #:iso-time-string #:parse-iso-time-string - #:soundex - #:string-soundex= - #:lru-cache - #:getcache #:cached - #:print-time-span - #:double-linked-list #:limited-list #:sorted-list - #:insert #:size - #:heap #:heap-add #:heap-pop #:heap-empty-p - #:double-linked-element #:make-double-linked-element #:double-linked-element-p - #:dle-previous #:dle-next #:dle-value - #:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle* - #:sl-map #:do-dll #:do-dll* - #:dll-find #:dll-find-cursor - #:push-first #:push-last #:dll-remove - #:pop-first #:pop-last - #:leap-year-p #:last-day-of-month - #:getuid #:setuid #:with-euid - #:get-logname #:get-user-name #:get-user-home #:find-uid - #:super-user-p - #:pathname-as-directory #:pathname-as-file - #:alist->plist #:plist->alist - #:byte-vector->string - #:string->byte-vector - #:outdated-p - #:with-hidden-temp-file - #:let-places #:let-slots - #:*decimal-point* - #:*thousands-comma* - #:format-amount #:parse-amount - #:with-package - #:make-directory #:ensure-directory - #:make-temp-directory - #:with-temp-directory - #:delete-directory - #:delete-directory-tree - #:do-directory-tree - #:traverse-directory-tree - #:empty-directory-p - #:remove-empty-directories - #:map-directory-tree - #:find-files - #:directory-p - #:regular-file-p - #:file-readable-p - #:file-writable-p - #:file-executable-p - #:current-directory - #:ensure-home-translations - #:list-directory - #:string-escape - #:string-substitute - #:bytes-simple-string - #:make-lock-files - #:with-lock-files - #:getpid - #:on-error - #:floor-to - #:round-to - #:ceiling-to - #:insert-in-order - #:forget-documentation - #:load-compiled - #:swap - #:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p - #:unix-stat #:unix-file-stat - #:stat-device - #:stat-inode - #:stat-links - #:stat-atime - #:stat-mtime - #:stat-ctime - #:stat-birthtime - #:stat-size - #:stat-blksize - #:stat-blocks - #:stat-uid - #:stat-gid - #:stat-mode - #:save-file-excursion - #:stat-modification-time - #:stat-creation-time - #:file-modification-time - #:file-creation-time - #:show - #:memoize-function - #:memoized - #:defun-memoized - #:parse-native-namestring - #:native-file-namestring - #:native-namestring - #:native-pathname - #:read-symbolic-link - #:symbolic-link-p - #:broken-link-p - #:circular-list - #:last-member - #:glob->regex - #:universal->unix-time #:unix->universal-time - #:get-unix-time - #:move-file - - ;; sysproc.lisp - #:*run-verbose* - #:run-pipe - #:run-program - #:run-shell-command - #:run-async-shell-command - #:exit-code - #:with-open-pipe - #:*bourne-shell* - #:sysproc-kill - #:sysproc-input - #:sysproc-output - #:sysproc-alive-p - #:sysproc-pid - #:sysproc-p - #:sysproc-wait - #:sysproc-exit-code - #:sysproc-set-signal-callback - - ;; MP - #:make-process - #:destroy-process - #:current-process - #:all-processes - #:processp - #:process-name - #:process-state - #:process-whostate - #:process-wait - #:process-wait-with-timeout - #:process-yield - #:process-interrupt - #:disable-process - #:enable-process - #:restart-process - #:without-scheduling - #:atomic-incf - #:atomic-decf - #:process-property-list - #:process-alive-p - #:process-join - ;; - #:make-lock - #:with-lock-held - #:make-recursive-lock - #:with-recursive-lock-held - ;; - #:make-condition-variable - #:condition-wait - #:condition-notify - #:process-property-list - #:process-execute - ;; mop.lisp - #:printable-object-mixin - )) diff --git a/third_party/lisp/sclf/sclf.asd b/third_party/lisp/sclf/sclf.asd deleted file mode 100644 index a9754b756900..000000000000 --- a/third_party/lisp/sclf/sclf.asd +++ /dev/null @@ -1,58 +0,0 @@ -;;; sclf.asd --- system definition - -;;; Copyright (C) 2005, 2006, 2008, 2009 by Walter C. Pelissero -;;; Copyright (C) 2021 by the TVL Authors - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: SCLF - -#+cmu (ext:file-comment "$Module: sclf.asd, Time-stamp: <2013-06-17 15:32:29 wcp> $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -(in-package :cl-user) - -(defpackage :sclf-system - (:use :common-lisp :asdf #+asdfa :asdfa)) - -(in-package :sclf-system) - -(defsystem sclf - :name "SCLF" - :author "Walter C. Pelissero <walter@pelissero.de>" - :maintainer "Walter C. Pelissero <walter@pelissero.de>" - ;; :version "0.0" - :description "Stray Common Lisp Functions" - :long-description - "A collection of Common Lisp functions for the most disparate -uses, too small to fit anywhere else." - :licence "LGPL" - :depends-on (#+sbcl :sb-posix) - :components - ((:doc-file "README") - (:file "package") - (:file "sclf" :depends-on ("package")) - (:file "sysproc" :depends-on ("package" "sclf")) - (:file "lazy" :depends-on ("package" "sclf")) - (:file "time" :depends-on ("package" "sclf")) - (:file "directory" :depends-on ("package" "sclf" "time")) - (:file "serial" :depends-on ("package" "sclf")) - (:module "mp" - :depends-on ("package" "sclf") - :components - ((:doc-file "README") - (:file #.(first - (list #+cmu "cmu" - #+sbcl "sbcl" - "unknown"))))))) diff --git a/third_party/lisp/sclf/sclf.lisp b/third_party/lisp/sclf/sclf.lisp deleted file mode 100644 index dfbc2078c829..000000000000 --- a/third_party/lisp/sclf/sclf.lisp +++ /dev/null @@ -1,1717 +0,0 @@ -;;; sclf.lisp --- miscellanea - -;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: SCLF - -#+cmu (ext:file-comment "$Module: sclf.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -;;; Commentary: - -;;; This is a collection of Common Lisp functions of the most disparate -;;; uses and purposes. These functions are too small or too unrelated -;;; to each other to deserve an own module. -;;; -;;; If you want to indent properly the following macros you should add -;;; the following lines to your .emacs file: -;;; -;;; (defun cl-indent-be (path state indent-point sexp-column normal-indent) -;;; (let ((sexp-start (cadr state)) -;;; (i 0)) -;;; (save-excursion -;;; (goto-char sexp-start) -;;; (forward-char) -;;; (+ sexp-column -;;; (block indentation -;;; (condition-case nil -;;; (while (< (point) indent-point) -;;; (setq i (1+ i)) -;;; (when (and (= 0 (logand i 1)) -;;; (looking-at "[\t\n ]*\\s(")) -;;; (return-from indentation 2)) -;;; (forward-sexp)) -;;; (error nil)) -;;; (if (= 1 (logand i 1)) -;;; 6 4)))))) -;;; -;;; (put 'be 'common-lisp-indent-function 'cl-indent-be) -;;; (put 'be* 'common-lisp-indent-function 'cl-indent-be) -;;; (put 'awhen 'lisp-indent-function 1) -;;; (put 'gcase 'lisp-indent-function 1) -;;; (put 'acase 'lisp-indent-function 1) -;;; (put 'acond 'lisp-indent-function 1) -;;; (put 'until 'lisp-indent-function 1) - - - -(cl:in-package :sclf) - -(defmacro be (&rest bindings-and-body) - "Less-parenthetic let." - (let ((bindings - (loop - while (and (symbolp (car bindings-and-body)) - (cdr bindings-and-body)) - collect (list (pop bindings-and-body) - (pop bindings-and-body))))) - `(let ,bindings - ,@bindings-and-body))) - -(defmacro be* (&rest bindings-and-body) - "Less-parenthetic let*." - (let ((bindings - (loop - while (and (symbolp (car bindings-and-body)) - (cdr bindings-and-body)) - collect (list (pop bindings-and-body) - (pop bindings-and-body))))) - `(let* ,bindings - ,@bindings-and-body))) - -(defmacro defconst (name value &rest etc) - "For some reason SBCL, between usefulness and adherence to the ANSI -standard, has chosen the latter, thus rendering the DEFCONSTANT pretty -useless. This macro works around that problem." - #+sbcl (list* 'defvar name value etc) - #-sbcl (list* 'defconstant name value etc)) - -(defmacro with-gensyms ((&rest symbols) &body body) - "Gensym all SYMBOLS and make them available in BODY. -See also LET-GENSYMS." - `(let ,(mapcar #'(lambda (s) - (list s '(gensym))) symbols) - ,@body)) - -(defun s+ (&rest strings) - "Return a string which is made of the concatenation of STRINGS." - (apply #'concatenate 'string strings)) - -(defun string-starts-with (prefix string &optional (compare #'string=)) - (be prefix-length (length prefix) - (and (>= (length string) prefix-length) - (funcall compare prefix string :end2 prefix-length)))) - -(defun string-ends-with (postfix string &optional (compare #'string=)) - "Return true if STRING's last characters are the same as POSTFIX." - (be postfix-length (length postfix) - string-length (length string) - (and (>= string-length postfix-length) - (funcall compare postfix string :start2 (- string-length postfix-length))))) - -(defun string-substitute (from to sequence &key (start 0) end (test #'eql)) - "Replace in SEQUENCE occurrences of FROM with TO. FROM and TO don't -need to be the same length." - (be from-length (length from) - (with-output-to-string (out) - (write-string sequence out :start 0 :end start) - (loop - for position = (search from sequence :start2 start :end2 end :test test) - while position - do - (write-string sequence out :start start :end position) - (write-string to out) - (setf start (+ position from-length)) - finally (write-string (subseq sequence start) out))))) - -(defun string-escape (string character &key (escape-character #\\) (escape-escape t)) - "Prepend all occurences of CHARACTER in STRING with a -ESCAPE-CHARACTER." - (with-output-to-string (stream) - (loop - for c across string - when (or (char= c character) - (and escape-escape - (char= c escape-character))) - do (write-char escape-character stream) - do (write-char c stream)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro aif (test then &optional else) - `(be it ,test - (if it - ,then - ,else))) - -(defmacro awhen (test &body then) - `(be it ,test - (when it - ,@then))) - -(defmacro acond (&body forms) - (when forms - `(aif ,(caar forms) - (progn ,@(cdar forms)) - (acond ,@(cdr forms))))) - -(defmacro aand (&rest args) - (cond ((null args) t) - ((null (cdr args)) (car args)) - (t `(aif ,(car args) (aand ,@(cdr args)))))) - -(defmacro acase (condition &body forms) - `(be it ,condition - (case it ,@forms))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst +whitespace+ '(#\return #\newline #\tab #\space #\page)) - -(defun string-trim-whitespace (string) - (string-trim +whitespace+ string)) - -(defun string-right-trim-whitespace (string) - (string-right-trim +whitespace+ string)) - -(defun string-left-trim-whitespace (string) - (string-left-trim +whitespace+ string)) - -(defun whitespace-p (char) - (member char +whitespace+)) - -(defun seq-whitespace-p (sequence) - (every #'whitespace-p sequence)) - -(defun not-empty (sequence) - "Return SEQUENCE if it's not empty, otherwise NIL. -NIL is indeed empty." - (when (or (listp sequence) - (not (zerop (length sequence)))) - sequence)) - -(defun position-any (bag sequence &rest position-args) - "Find any element of bag in sequence and return its position. -Accept any argument accepted by the POSITION function." - (apply #'position-if #'(lambda (element) - (find element bag)) sequence position-args)) - -(defun find-any (bag sequence &rest find-args) - "Find any element of bag in sequence. Accept any argument -accepted by the FIND function." - (apply #'find-if #'(lambda (element) - (find element bag)) sequence find-args)) - -(defun split-at (bag sequence &key (start 0) key) - "Split SEQUENCE at occurence of any element from BAG. -Contiguous occurences of elements from BAG are considered atomic; -so no empty sequence is returned." - (be len (length sequence) - (labels ((split-from (start) - (unless (>= start len) - (be sep (position-any bag sequence :start start :key key) - (cond ((not sep) - (list (subseq sequence start))) - ((> sep start) - (cons (subseq sequence start sep) - (split-from (1+ sep)))) - (t - (split-from (1+ start)))))))) - (split-from start)))) - -(defun split-string-at-char (string separator &key escape skip-empty) - "Split STRING at SEPARATORs and return a list of the substrings. If -SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is -not nil then split at SEPARATOR only if it's not preceded by ESCAPE." - (declare (type string string) (type character separator)) - (labels ((next-separator (beg) - (be pos (position separator string :start beg) - (if (and escape - pos - (plusp pos) - (char= escape (char string (1- pos)))) - (next-separator (1+ pos)) - pos))) - (parse (beg) - (cond ((< beg (length string)) - (let* ((end (next-separator beg)) - (substring (subseq string beg end))) - (cond ((and skip-empty (string= "" substring)) - (parse (1+ end))) - ((not end) - (list substring)) - (t - (cons substring (parse (1+ end))))))) - (skip-empty - '()) - (t - (list ""))))) - (parse 0))) - -(defun copy-stream (in out) - (loop - for c = (read-char in nil) - while c - do (write-char c out))) - -(defun pathname-as-file (pathname) - "Converts PATHNAME to file form and return it." - (unless (pathnamep pathname) - (setf pathname (pathname pathname))) - (cond ((pathname-name pathname) - pathname) - ((stringp (car (last (pathname-directory pathname)))) - (be name (parse-native-namestring (car (last (pathname-directory pathname)))) - (make-pathname :directory (butlast (pathname-directory pathname)) - :name (pathname-name name) - :type (pathname-type name) - :defaults pathname))) - ;; it can't be done? - (t pathname))) - -(defun copy-file (file copy-file &key (if-exists :error)) - (with-open-file (in file) - (with-open-file (out copy-file :direction :output :if-exists if-exists) - (copy-stream in out)))) - -(defun symlink-file (src dst &key (if-exists :error)) - (when (and (eq :supersede if-exists) - (probe-file dst)) - (delete-file dst)) - #+sbcl (sb-posix:symlink src dst) - #+cmu(unix:unix-symlink (native-namestring src) (native-namestring dst)) - #-(or sbcl cmu) (error "don't know how to symlink files")) - -(defun read-whole-stream (stream) - "Read stream until the end and return it as a string." - (with-output-to-string (string) - (loop - for line = (read-line stream nil) - while line - do (write-line line string)))) - -(defun read-lines (stream &optional n) - "Read N lines from stream and return them as a list of strings. If -N is NIL, read the whole stream til the end. If the stream ends -before N lines a read, this function will return those without -signalling an error." - (loop - for line = (read-line stream nil) - for i from 0 - while (and line - (or (not n) - (< i n))) - collect line)) - -(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) - "Read the whole content of file and return it as a sequence which -can be a string, a vector of bytes, or whatever you specify as -ELEMENT-TYPE." - (with-open-file (in pathname - :element-type element-type - :if-does-not-exist (unless (eq :value if-does-not-exist) - :error)) - (if in - (be seq (make-array (file-length in) :element-type element-type) - (read-sequence seq in) - seq) - default))) - -(defun write-file (pathname contents &key (if-exists :error)) - "Read the whole content of file and return it as a sequence which -can be a string, a vector of bytes, or whatever you specify as -ELEMENT-TYPE." - (with-open-file (out pathname - :element-type (if (stringp contents) - 'character - (array-element-type contents)) - :if-exists if-exists) - (write-sequence contents out))) - -(defun read-from-file (pathname &key (on-error :error) default) - "Similar to READ-FROM-STRING but for files. Read the first Lisp -object in file and return it. If file does not exist or does not -contain a readable Lisp object, ON-ERROR tells what to do. If -ON-ERROR is :ERROR, an error is signalled. If ON-ERROR is :VALUE, -DEFAULT is returned." - (ecase on-error - (:error - (with-open-file (in pathname) - (read in))) - (:value - (handler-case (with-open-file (in pathname) - (read in)) - (t () - default))))) - -(defun write-to-file (object pathname &key (if-exists :error) pretty) - "Similar to WRITE-TO-STRING but for files. Write OBJECT to a file -with pathname PATHNAME." - (with-open-file (out pathname :direction :output :if-exists if-exists) - (write object :stream out :escape t :readably t :pretty pretty))) - -(defun string-concat (list &optional (separator "")) - "Concatenate the strings in LIST interposing SEPARATOR (default -nothing) between them." - (reduce #'(lambda (&rest args) - (if args - (s+ (car args) separator (cadr args)) - "")) - list)) - -;; to indent it properly: (put 'gcase 'lisp-indent-function 1) -(defmacro gcase ((value &optional (test 'equalp)) &rest cases) - "Generic CASE macro. Match VALUE to CASES as if by the normal CASE -but use TEST as the comparison function, which defaults to EQUALP." - (with-gensyms (val) - `(be ,val ,value - ,(cons 'cond - (mapcar #'(lambda (case-desc) - (destructuring-bind (vals &rest forms) case-desc - `(,(cond ((consp vals) - (cons 'or (mapcar #'(lambda (v) - (list test val v)) - vals))) - ((or (eq vals 'otherwise) - (eq vals t)) - t) - (t (list test val vals))) - ,@forms))) - cases))))) - -(defun string-truncate (string max-length) - "If STRING is longer than MAX-LENGTH, return a shorter version. -Otherwise return the same string unchanged." - (if (> (length string) max-length) - (subseq string 0 max-length) - string)) - -;; to indent properly: (put 'until 'lisp-indent-function 1) -(defmacro until (test &body body) - (with-gensyms (result) - `(loop - for ,result = ,test - until ,result - do (progn ,@body) - finally (return ,result)))) - -(defun keywordify (string) - (intern (string-upcase string) :keyword)) - -(defun locate-system-program (name) - "Given the NAME of a system program try to find it through the -search of the environment variable PATH. Return the full -pathname." - (loop - for dir in (split-string-at-char (getenv "PATH") #\:) - for pathname = (merge-pathnames name (pathname-as-directory dir)) - when (probe-file pathname) - return pathname)) - -(defvar *tmp-file-defaults* #P"/tmp/") - -(defun temp-file-name (&optional (default *tmp-file-defaults*)) - "Create a random pathname based on DEFAULT. No effort is made -to make sure that the returned pathname doesn't identify an -already existing file. If missing DEFAULT defaults to -*TMP-FILE-DEFAULTS*." - (make-pathname :defaults default - :name (format nil "~36R" (random #.(expt 36 10))))) - -(defun open-temp-file (&optional default-pathname &rest open-args) - "Open a new temporary file and return a stream to it. This function -makes sure the pathname of the temporary file is unique. OPEN-ARGS -are arguments passed verbatim to OPEN. If OPEN-ARGS specify -the :DIRECTION it should be either :OUTPUT (default) or :IO; -any other value causes an error. If DEFAULT-PATHNAME is specified and -not NIL it's used as defaults to produce the pathname of the temporary -file, otherwise *TMP-FILE-DEFAULTS* is used." - (unless default-pathname - (setf default-pathname *tmp-file-defaults*)) - ;; if :DIRECTION is specified check that it's compatible with the - ;; purpose of this function, otherwise make it default to :OUTPUT - (aif (getf open-args :direction) - (unless (member it '(:output :io)) - (error "Can't create temporary file with open direction ~A." it)) - (setf open-args (append '(:direction :output) - open-args))) - (do* ((name #1=(temp-file-name default-pathname) #1#) - (stream #2=(apply #'open name - :if-exists nil - :if-does-not-exist :create - open-args) #2#)) - (stream stream))) - -(defmacro with-temp-file ((stream &rest open-temp-args) &body body) - "Execute BODY within a dynamic extent where STREAM is bound to -a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are -passed verbatim to OPEN-TEMP-FILE." - `(be ,stream (open-temp-file ,@open-temp-args) - (unwind-protect - (progn ,@body) - (close ,stream) - ;; body may decide to rename the file so we must ignore the errors - (ignore-errors - (delete-file (pathname ,stream)))))) - -(defmacro with-hidden-temp-file ((stream &rest open-args) &body body) - "Just like WITH-TEMP-FILE but unlink (delete) the temporary file -before the execution of BODY. As such BODY won't be able to -manipulate the file but through STREAM, and no other program is able -to see it. Once STREAM is closed the temporary file blocks are -automatically relinquished by the operating system. This works at -least on Unix filesystems. I don't know about MS-OSs where the system -may likely decide to crash, take all your data with it and, in the -meanwhile, report you to the NSA as terrorist." - `(be ,stream (open-temp-file ,@open-args) - (unwind-protect - (progn (delete-file (pathname ,stream)) - ,@body) - (close ,stream)))) - -(defun insert-in-order (item seq &key (test #'<) key) - "Destructively insert ITEM in LIST in order by TEST. Return -the new list. This is a simple wrapper around MERGE." - (merge (if seq - (type-of seq) - 'list) - (list item) seq test :key key)) - -(defmacro f++ (x &optional (delta 1)) - "Same as INCF but hopefully optimised for fixnums." - `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) - -(defun soundex (word &optional (key-length 4)) - "Knuth's Soundex algorithm. Returns a string representing the -sound of a certain word (English). Different words will thus -yield the same output string. To compare two string by the -sound, simply do: - - (string= (soundex str1) (soundex str2)) - -Examples: - - (soundex \"Knuth\") => \"K530\" - (soundex \"Kant\") => \"K530\" - (soundex \"Lloyd\") => \"L300\" - (soundex \"Ladd\") => \"L300\"" - (declare (type string word)) - (flet ((translate-char (char) - (awhen (position char "BFPVCGJKQSXZDTLMNR") - (elt "111122222222334556" it)))) - (let ((key (make-string key-length :initial-element #\0)) - (word-length (length word))) - (setf (elt key 0) (elt word 0)) - (loop - with previous-sound = (translate-char (char-upcase (elt word 0))) - with j = 1 - for i from 1 by 1 below word-length - for c = (char-upcase (elt word i)) - while (< j key-length) - do (be sound (translate-char c) - (cond ((not (eq sound previous-sound)) - (unless (member c '(#\H #\W)) - (setf previous-sound sound)) - (when sound - (setf (elt key j) sound) - (incf j)))))) - key))) - -(defun string-soundex= (string1 string2) - (let ((l1 (split-at +whitespace+ string1)) - (l2 (split-at +whitespace+ string2))) - (and (= (length l1) (length l2)) - (every #'string= (mapcar #'soundex l1) (mapcar #'soundex l2))))) - -#+(OR) -(defun soundex-test () - (let* ((words1 '("Euler" "Gauss" "Hilbert" "Knuth" "Lloyd" "Lukasiewicz" "Wachs")) - (words2 '("Ellery" "Ghosh" "Heilbronn" "Kant" "Ladd" "Lissajous" "Waugh")) - (results '("E460" "G200" "H416" "K530" "L300" "L222" "W200"))) - (mapc #'(lambda (w1 w2 r) - (let ((r1 (soundex w1)) - (r2 (soundex w2))) - (format t "~A = ~A, ~A = ~A => ~A~%" w1 r1 w2 r2 - (if (and (string= r1 r2) - (string= r r1)) - "OK" - (format nil "ERROR (expected ~A)" r))))) - words1 words2 results) - (values))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; (defstruct cache-slot () -;; ((previous :type (or cache-slot null) -;; :initarg :previous -;; :initform nil -;; :accessor cslot-previous) -;; (key :initarg :key -;; :accessor cslot-key) -;; (value :initarg :value -;; :accessor cslot-value) -;; (next :type (or cache-slot null) -;; :initarg :next -;; :initform nil -;; :accessor cslot-next))) - -;; (defmethod print-object ((object cache-slot) stream) -;; (print-unreadable-object (object stream :type t) -;; (if (slot-boundp object 'key) -;; (format stream "key=~S, value=~S" (cslot-key object) (cslot-value object)) -;; (format stream "NULL")))) - - -(defstruct (double-linked-element (:conc-name dle-)) - (previous nil :type (or double-linked-element null)) - value - (next nil :type (or double-linked-element null))) - -(defmethod print-object ((object double-linked-element) stream) - (print-unreadable-object (object stream :type t) - (format stream "value=~S" (dle-value object)))) - -(defun cons-dle (value previous next) - (declare (type (or double-linked-element null) previous next)) - (be new-element (make-double-linked-element :previous previous :next next :value value) - (when previous - (setf (dle-next previous) new-element)) - (when next - (setf (dle-previous next) new-element)) - new-element)) - -(defun dle-remove (dle-object) - "Remove the DLE-OBJECT from its current position in the list of -elements agjusting the pointer of dle-objects before and after this -one (if any)." - (declare (type double-linked-element dle-object)) - (awhen (dle-next dle-object) - (setf (dle-previous it) (dle-previous dle-object))) - (awhen (dle-previous dle-object) - (setf (dle-next it) (dle-next dle-object)))) - -(defun dle-map (function dle-object) - (when dle-object - (make-double-linked-element :value (funcall function (dle-value dle-object)) - :previous (dle-previous dle-object) - :next (dle-map function (dle-next dle-object))))) - -(defmacro do-dle ((var dle &optional (result nil)) &body body) - "Iterate over a list of DOUBLE-LINKED-ELEMENTs and map body to -each element's value. Bind VAR to the value on each iteration." - (be cursor (gensym) - `(do ((,cursor ,dle (dle-next ,cursor))) - ((not ,cursor) ,result) - (be ,var (dle-value ,cursor) - ,@body)))) - -(defmacro do-dle* ((var dle &optional (result nil)) &body body) - "Same as DO-DLE but VAR is a symbol macro, so that BODY can -modify the element's value." - (be cursor (gensym) - `(symbol-macrolet ((,var (dle-value ,cursor))) - (do ((,cursor ,dle (dle-next ,cursor))) - ((not ,cursor) ,result) - ,@body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass double-linked-list () - ((elements :type double-linked-element - :documentation "The actual list of elements held by this object.") - (last-element :type double-linked-element)) - (:documentation - "A double linked list where elements can be added or removed -from either end.")) - -(defmethod initialize-instance ((object double-linked-list) &rest rest) - (declare (ignorable rest)) - (call-next-method) - (with-slots (last-element elements) object - (setf last-element (make-double-linked-element) - elements last-element))) - -(defmethod print-object ((object double-linked-list) stream) - (print-unreadable-object (object stream :type t) - (be elements '() - (do-dle (e (slot-value object 'elements)) - (push e elements)) - (format stream "elements=~S" (nreverse elements))))) - -(defgeneric pop-first (double-linked-list) - (:documentation - "Pop the first element of a double-linked-list.")) -(defgeneric pop-last (double-linked-list) - (:documentation - "Pop the last element of a double-linked-list.")) -(defgeneric push-first (item double-linked-list) - (:documentation - "Push an item in front of a double-linked-list.")) -(defgeneric push-last (item double-linked-list) - (:documentation - "Append an item to a double-linked-list.")) -(defgeneric list-map (function double-linked-list) - (:documentation - "Map a function to a double-linked-list.")) -(defgeneric dll-find-cursor (object dll &key test key)) -(defgeneric dll-find (object dll &key test key)) -(defgeneric dll-remove (cursor dll)) - -(defmethod pop-last ((list double-linked-list)) - "Drop the last element in the dl list." - (with-slots (last-element) list - (awhen (dle-previous last-element) - (dle-remove it) - (dle-value it)))) - -(defmethod pop-first ((list double-linked-list)) - "Drop the first element in the dl list." - (with-slots (elements) list - (when (dle-next elements) - (prog1 (dle-value elements) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))))) - -(defmethod push-first (value (list double-linked-list)) - (with-slots (elements) list - (setf elements (cons-dle value nil elements))) - list) - -(defmethod push-last (value (list double-linked-list)) - (with-slots (last-element) list - (cons-dle value (dle-previous last-element) last-element)) - list) - -(defmethod list-map (function (list double-linked-list)) - (labels ((map-dll (dle) - (when (dle-next dle) - (make-double-linked-element - :value (funcall function (dle-value dle)) - :previous (dle-previous dle) - :next (map-dll (dle-next dle)))))) - (map-dll (slot-value list 'elements)))) - -(defmethod dll-find-cursor (object (list double-linked-list) &key (test #'eql) (key #'identity)) - (do ((cursor (slot-value list 'elements) (dle-next cursor))) - ((not (dle-next cursor))) - (be value (dle-value cursor) - (when (funcall test (funcall key value) object) - (return cursor))))) - -(defmethod dll-find (object (list double-linked-list) &key (test #'eql) (key #'identity)) - (awhen (dll-find-cursor object list :test test :key key) - (dle-value it))) - -(defmethod dll-remove ((cursor double-linked-element) (list double-linked-list)) - (with-slots (elements) list - (if (dle-previous cursor) - (dle-remove cursor) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))) - list) - -(defmacro do-dll ((var list &optional (result nil)) &body body) - "Iterate over a dll and map body to each element's -value. Bind VAR to the value on each iteration." - (be cursor (gensym) - `(do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) - ((not (dle-next ,cursor)) ,result) - (be ,var (dle-value ,cursor) - ,@body)))) - -(defmacro do-dll* ((var list &optional (result nil)) &body body) - "Same as DO-DLL but VAR is a symbol macro, so that BODY can -modify the element's value." - (be cursor (gensym) - `(symbol-macrolet ((,var (dle-value ,cursor))) - (do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor))) - ((not (dle-next ,cursor)) ,result) - ,@body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass limited-list (double-linked-list) - ((max-size :initform nil - :initarg :size - :reader max-size - :type (or integer null) - :documentation "Size limit to which the list is allowed to grow to. NIL = no limit.") - (size :initform 0 - :reader size - :type integer - :documentation "Current number of elements in the list.")) - (:documentation - "A double linked list where the maximum number of elements can -be limited.")) - -(defun dll-member-p (dle list) - (with-slots (elements size) list - (do ((e elements (dle-next e))) - ((not e)) - (when (eq e dle) - (return t))))) - -(defmethod dll-remove ((cursor double-linked-element) (list limited-list)) - (with-slots (size) list - (unless (zerop size) - (decf size) - (call-next-method))) - list) - -(defmethod pop-first ((list limited-list)) - (with-slots (size) list - (unless (zerop size) - (decf size) - (call-next-method)))) - -(defmethod pop-last ((list limited-list)) - (with-slots (size) list - (unless (zerop size) - (decf size) - (call-next-method)))) - -(defmethod push-first (value (list limited-list)) - "Add in front of the list and drop the last element if list is -full." - (declare (ignore value)) - (prog1 (call-next-method) - (with-slots (max-size size last-element) list - (if (or (not max-size) - (< size max-size)) - (incf size) - (dle-remove (dle-previous last-element)))))) - -(defmethod push-last (value (list limited-list)) - "Add at the end of the list and drop the first element if list -is full." - (declare (ignore value)) - (prog1 (call-next-method) - (with-slots (max-size size elements) list - (if (or (not max-size) - (< size max-size)) - (incf size) - (setf (dle-previous (dle-next elements)) nil - elements (dle-next elements)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass sorted-list (limited-list) - ((test :type function - :initarg :test)) - (:documentation - "A double linked list where elements are inserted in a -sorted order.")) - -(defgeneric insert (item sorted-list) - (:documentation - "Insert an item in a sorted-list.")) - -(defmethod insert (item (sl sorted-list)) - "Insert ITEM in SL, which is a sorted double linked list, -before the item for which TEST is true or at the end of the list. -Returns two values, the modified list and the cursor to the new -element." - (with-slots (max-size size elements test last-element) sl - (do ((cursor elements (dle-next cursor))) - ((or (not (dle-next cursor)) - (funcall test item (dle-value cursor))) - (if (dle-previous cursor) - (cons-dle item (dle-previous cursor) cursor) - (setf elements (cons-dle item nil cursor))) - (if (or (not max-size) - (< size max-size)) - (incf size) - (dle-remove (dle-previous last-element))) - (values sl (dle-previous cursor)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass heap () - ((less-than :type function - :initarg :test - :documentation "The heap invariant.") - (data :type array - :documentation "The heap tree representation."))) - -(defmethod initialize-instance ((heap heap) &rest args) - (declare (ignore args)) - (call-next-method) - (with-slots (data) heap - (setf data (make-array 0 :fill-pointer 0 :adjustable t)))) - -(defgeneric heap-add (heap item)) - -(defun bubble-up (heap pos) - (with-slots (data less-than) heap - (loop - for current = pos then parent - for parent = (truncate (1- current) 2) - until (or (zerop current) - (funcall less-than (aref data parent) (aref data current))) - do (rotatef (aref data current) (aref data parent))))) - -(defmethod heap-add ((heap heap) item) - (with-slots (data) heap - (vector-push-extend item data) - (bubble-up heap (1- (fill-pointer data))))) - -(defgeneric heap-size (heap)) - -(defmethod heap-size ((heap heap)) - (fill-pointer (slot-value heap 'data))) - -(defgeneric heap-empty-p (heap)) - -(defmethod heap-empty-p ((heap heap)) - (zerop (heap-size heap))) - - -(defgeneric heap-pop (heap)) - -(defun percolate-down (heap pos) - (with-slots (data less-than) heap - (loop - with end = (fill-pointer data) - for current = pos then child - for left-child = (+ 1 (* 2 current)) - for right-child = (+ 2 (* 2 current)) - for child = (cond ((>= left-child end) - (return)) - ((>= right-child end) - left-child) - ((funcall less-than (aref data left-child) (aref data right-child)) - left-child) - (t - right-child)) - while (funcall less-than (aref data child) (aref data current)) - do (rotatef (aref data current) (aref data child))))) - -(defmethod heap-pop ((heap heap)) - (assert (not (heap-empty-p heap))) - (with-slots (data) heap - (be root (aref data 0) - (setf (aref data 0) (vector-pop data)) - (percolate-down heap 0) - root))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct (lru-cache-slot (:include double-linked-element) - (:conc-name lruc-slot-)) - key) - -(defmethod print-object ((object lru-cache-slot) stream) - (print-unreadable-object (object stream :type t) - (format stream "key=~S value=~S" (lruc-slot-key object) (lruc-slot-value object)))) - -(defvar *default-cache-size* 100 - "Default size of a LRU cache if it's not specified at instantiation -time.") - -(defclass lru-cache () - ((max-size :initform *default-cache-size* - :initarg :size - :reader max-size - :type (or integer null) - :documentation - "Maximum number of elements that the cache can fit.") - (elements-list :type lru-cache-slot - :documentation "The list of elements held by the cache.") - (elements-hash :type hash-table - :documentation "The hash table of the elements held bye the cache.") - (last-element :type lru-cache-slot) - (size :initform 0 - :reader size - :type integer - :documentation "Current number of elements in the cache.") - (finalizer :initform nil - :initarg :finalizer - :documentation - "Procedure to call when elements are dropped from cache.")) - (:documentation - "An objects cache that keeps the elements used more often and -drops those that are used less often. The usage is similar to an -hash table. Elements are added to the list up to MAX-SIZE, then -any new element will drop the less used one in the cache. Every -time an element is set or retrieved it goes in front of a list. -Those which get at the end of the list are dropped when more room -is required.")) - -(defmethod initialize-instance ((object lru-cache) &key test &allow-other-keys) - (call-next-method) - (with-slots (last-element elements-list elements-hash) object - (setf last-element (make-lru-cache-slot) - elements-list last-element - elements-hash (if test - (make-hash-table :test test) - (make-hash-table))))) - -(defgeneric getcache (key cache) - (:documentation - "Get an item with KEY from a CACHE.")) - -(defgeneric (setf getcache) (value key cache) - (:documentation - "Set or add an item with KEY in a CACHE.")) - -(defgeneric remcache (key cache) - (:documentation - "Remove an item with KEY from a CACHE.")) - -(defun move-in-front-of-cache-list (slot cache) - "Relocate slot to the front of the elements list in cache. -This will stretch its lifespan in the cache." - (declare (type lru-cache-slot slot) - (type lru-cache cache)) - (with-slots (elements-list) cache - ;; unless it's already the first - (unless (eq slot elements-list) - ;; remove the slot from its original place... - (dle-remove slot) - ;; ... and add it in front of the list - (setf (lruc-slot-next slot) elements-list - (lruc-slot-previous slot) nil - (lruc-slot-previous elements-list) slot - elements-list slot)))) - -(defun drop-last-cache-element (cache) - "Drop the last element in the list of the cache object." - (declare (type lru-cache cache)) - (with-slots (last-element elements-hash finalizer) cache - (let ((second-last (lruc-slot-previous last-element))) - (assert second-last) - (when finalizer - (funcall finalizer (lruc-slot-value second-last))) - (dle-remove second-last) - (remhash (lruc-slot-key second-last) elements-hash)))) - -(defun add-to-cache (slot cache) - (declare (type lru-cache-slot slot) - (type lru-cache cache)) - (move-in-front-of-cache-list slot cache) - (with-slots (max-size size elements-hash) cache - (setf (gethash (lruc-slot-key slot) elements-hash) slot) - (if (and max-size - (< size max-size)) - (incf size) - (drop-last-cache-element cache)))) - -(defmethod getcache (key (cache lru-cache)) - (multiple-value-bind (slot found?) (gethash key (slot-value cache 'elements-hash)) - (when found? - (move-in-front-of-cache-list slot cache) - (values (lruc-slot-value slot) t)))) - -(defmethod (setf getcache) (value key (cache lru-cache)) - (with-slots (elements-hash elements-list) cache - (multiple-value-bind (slot found?) (gethash key elements-hash) - (if found? - (progn - (move-in-front-of-cache-list slot cache) - (setf (lruc-slot-value slot) value)) - (add-to-cache (make-lru-cache-slot :key key :value value) cache)) - value))) - -(defmethod remcache (key (cache lru-cache)) - (with-slots (elements-hash size elements-list finalizer) cache - (multiple-value-bind (slot found?) (gethash key elements-hash) - (when found? - (remhash key elements-hash) - (when finalizer - (funcall finalizer (lruc-slot-value slot))) - (when (eq slot elements-list) - (setf elements-list (dle-next slot))) - (dle-remove slot) - (decf size) - t)))) - -(defmacro cached (cache key value) - "If KEY is found in CACHE return the associated object. Otherwise -store VALUE for later re-use." - (with-gensyms (object my-cache my-key my-value found?) - `(let* ((,my-cache ,cache) - (,my-key ,key)) - (multiple-value-bind (,object ,found?) (getcache ,my-key ,my-cache) - (if ,found? - ,object - (let ((,my-value ,value)) - (setf (getcache ,my-key ,my-cache) ,my-value) - ,my-value)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(declaim (inline list->string)) -(defun list->string (list) - "Coerce a list of characters into a string." - (coerce list 'string)) - -(defun setuid (id) - "Set the Unix real user id." - (when (stringp id) - (setf id (find-uid id))) - #+sbcl (sb-posix:setuid id) - #+cmu (unix:unix-setuid id) - #+clisp (posix::%setuid id) ; not verified -wcp26/8/09. - #-(or cmu sbcl clisp) - (error "setuid unsupported under this Lisp implementation")) - -(defun seteuid (id) - "Set the Unix effective user id." - (when (stringp id) - (setf id (find-uid id))) - #+sbcl (sb-posix:seteuid id) - #+cmu (unix:unix-setreuid -1 id) - #+clisp (posix::%seteuid id) ; not verified -wcp26/8/09. - #-(or cmu sbcl clisp) - (error "seteuid unsupported under this Lisp implementation")) - -(defun find-uid (name) - "Find the user id of NAME. Return an integer." - #+sbcl (awhen (sb-posix:getpwnam name) - (sb-posix:passwd-uid it)) - #+cmu (awhen (unix:unix-getpwnam name) - (unix:user-info-uid it)) - #-(or cmu sbcl) - (error "Unable to find a UID on this Lisp system.")) - -#+clisp (ffi:def-call-out %getuid - (:name "getuid") - (:arguments) - (:return-type ffi:int) - (:library "libc.so")) - -(defun getuid () - "Return the Unix user id. This is an integer." - #+sbcl (sb-unix:unix-getuid) - #+cmu (unix:unix-getuid) - #+clisp (%getuid) - #-(or cmu sbcl clisp) - (error "getuid unsupported under this Lisp implementation")) - -(defun super-user-p (&optional id) - "Return true if the user ID is zero. ID defaults to the current -user id." - (zerop (or id (getuid)))) - -(defmacro with-euid (uid &body forms) - "Switch temporarely to Unix user id UID, while performing FORMS." - (with-gensyms (ruid) - `(be ,ruid (getuid) - (seteuid ,uid) - (unwind-protect (progn ,@forms) - (seteuid ,ruid))))) - -(defun get-logname (&optional uid) - "Return the login id of the user. This is a string and it is not -the Unix uid, which is a number." - (unless uid - (setf uid (getuid))) - (when (stringp uid) - (setf uid (find-uid uid))) - (when uid - #+sbcl (sb-unix:uid-username uid) - #+cmu (unix:user-info-name (unix:unix-getpwuid uid)) - #+clisp (posix:user-info-login-id (posix:user-info uid)) - #-(or cmu sbcl clisp) - (error "get-logname unsupported under this Lisp implementation"))) - -(defun get-user-name (&optional uid) - "Return the user name, taken from the GCOS field of the /etc/passwd -file." - (unless uid - (setf uid (getuid))) - (when (stringp uid) - (setf uid (find-uid uid))) - (when uid - (car (split-string-at-char #+cmu (unix:user-info-gecos (unix:unix-getpwuid uid)) - #+sbcl (sb-posix:passwd-gecos (sb-posix:getpwuid uid)) - #-(or cmu sbcl) (error "can't getpwuid() on this Lisp system.") - #\,)))) - -(defun get-user-home (&optional uid) - (unless uid - (setf uid (getuid))) - (when (stringp uid) - (setf uid (find-uid uid))) - (when uid - #+cmu (unix:user-info-dir (unix:unix-getpwuid uid)) - #+sbcl (sb-posix:passwd-dir (sb-posix:getpwuid uid)))) - -;; Rather stupid, but the mnemonic is worth it -(declaim (inline alist->plist)) -(defun alist->plist (alist) - "Convert an association list into a property list. The alist -elements are assumed to be lists of just two elements: the key -and the value. If the element list is longer this function -doesn't work." - (mapcan #'identity alist)) - -(defun plist->alist (plist &optional pairs-p) - "Convert a property list into an association list. The alist -elements wiil be lists of just two elements: the key and the -value. If PAIRS-P is true the alist elements will be pairs." - (loop - for (key val) on plist by #'cddr - collect (if pairs-p - (cons key val) - (list key val)))) - -(defun string->byte-vector (string &key start end) - "Convert a string of characters into a vector of (unsigned-byte -8) elements." - (map '(vector (unsigned-byte 8)) #'char-code - (if (or start end) - (subseq string (or start 0) end) - string))) - -(defun byte-vector->string (vector &key start end) - "Convert a vector of (unsigned-byte 8) elements into a string -of characters." - (map 'string #'code-char - (if (or start end) - (subseq vector (or start 0) end) - vector))) - -(defun outdated-p (file dependencies) - "Check if FILE has been modified before any of its -DEPENDENCIES." - (be epoch (and (probe-file file) - (file-write-date file)) - ;; if file is missing altogether, we consider it outdated - (or (not epoch) - (loop - for dep in dependencies - thereis (aand (probe-file dep) - (file-write-date dep) - (> it epoch)))))) - -(defmacro let-places (places-and-values &body body) - "Execute BODY binding temporarily some places to new values and -restoring the original values of these places on exit of BODY. The -syntax of this macro is identical to LET. The difference is that -instead of new variable names this macro binds values to existing -places (variables)." - (be tmp-variables (loop for x in places-and-values collect (gensym)) - `(let ,(mapcar #'(lambda (tmp-var place-and-value) - (list tmp-var (car place-and-value))) - tmp-variables places-and-values) - (unwind-protect - (progn - ;; as some assignments could signal an error, we assign - ;; within the unwind-protect block so that we can always - ;; guarantee a consistent state on exit - ,@(mapcar #'(lambda (place-and-value) - `(setf ,(car place-and-value) ,(cadr place-and-value))) - places-and-values) - ,@body) - ,@(mapcar #'(lambda (tmp-var place-and-value) - `(setf ,(car place-and-value) ,tmp-var)) - tmp-variables - places-and-values))))) - -(defmacro let-slots (accessor/new-value-pairs object &body body) - "Execute BODY with some OBJECT's slots temporary sets to new -values as described in ACCESSOR/NEW-VALUE-PAIRS. The latter -should be an alist of accessor names and the value to be assigned -to that slot. On exit from BODY, those slots are restored to -their original value. See LET-PLACES." - (with-gensyms (obj) - `(be ,obj ,object - (let-places ,(mapcar #'(lambda (av) - `((,(car av) ,obj) ,(cadr av))) - accessor/new-value-pairs) - ,@body)))) - -(defvar *decimal-point* #\.) -(defvar *thousands-comma* #\,) - -(defun format-amount (number &key (decimals 2) (rounder #'round) - (comma *thousands-comma*) (comma-stance 3) - (decimal-point *decimal-point*)) - "Return a string formatted as fixed decimal point number of DECIMALS -adding commas every COMMA-STANCE places before the decimal point." - (declare (type number number) - (type fixnum decimals comma-stance) - (type function rounder) - (type character comma decimal-point) - (optimize (speed 3) (safety 0) (debug 0))) - (let* ((int (funcall rounder (* number (expt 10 decimals)))) - (negative (< int 0))) - (declare (integer int)) - (when negative - (setf int (- int))) - (let* ((digits (max (1+ decimals) - (1+ (if (zerop int) - 0 - (truncate (log int 10)))))) - (string-length (+ digits - ;; the minus sign - (if negative 1 0) - ;; the decimal point - (if (zerop decimals) 0 1) - ;; the thousands commas - (1- (ceiling (- digits decimals) comma-stance)))) - (string (make-string string-length)) - (pos (1- string-length))) - (declare (type fixnum pos digits)) - (labels ((add-char (char) - (setf (schar string pos) char) - (decf pos)) - (add-digit () - (add-char (digit-char (mod int 10))) - (setf int (truncate int 10)))) - (unless (zerop decimals) - (loop - for i fixnum from 0 below decimals - do (add-digit)) - (add-char decimal-point)) - (loop - for i fixnum from 1 - do (add-digit) - while (>= pos (if negative 1 0)) - when (zerop (mod i comma-stance)) - do (add-char comma)) - (when negative - (add-char #\-))) - string))) - -(defun parse-amount (string &key (start 0) end) - "Parse STRING as if it was formatted with FORMAT-AMOUNT and return -the parsed number. Return NIL if STRING is malformed. Leading or -trailing spaces must be removed from the string in advance." - (loop - with amount = 0 - with decimals = nil - with negative = (when (and (not (zerop (length string))) - (char= #\- (char string 0))) - (incf start) - t) - for i from start below (or end (length string)) - for c = (char string i) - do (cond ((char= c *decimal-point*) - (if decimals - (return nil) - (setf decimals 0))) - ((char= c *thousands-comma*)) - (t - (be d (digit-char-p c) - (cond ((not d) - (return nil)) - (decimals - (incf decimals) - (incf amount (/ d (expt 10 decimals)))) - (t - (setf amount (+ d (* amount 10)))))))) - finally (return (if negative - (- amount) - amount)))) - -(defmacro with-package (name &body body) - `(let ((*package* (find-package ,name))) - ,@body)) - -(defun bytes-simple-string (n &optional imply-bytes) - "Return a string describing N using a unit of measure multiple -of a byte that is most apporpriate for the magnitude of N. A -kilobyte is 1024 not 1000 bytes, everything follows." - (let* ((kilo 1024) - (mega (* kilo kilo)) - (giga (* kilo mega)) - (tera (* mega mega)) - (peta (* kilo tera))) - (apply #'format nil "~,1F~A" - (cond ((> n (* 2 peta)) - (list (/ n peta) (if imply-bytes "P" "PB"))) - ((> n (* 2 tera)) - (list (/ n tera) (if imply-bytes "T" "TB"))) - ((> n (* 2 giga)) - (list (/ n giga) (if imply-bytes "G" "GB"))) - ((> n (* 2 mega)) - (list (/ n mega) (if imply-bytes "M" "MB"))) - ((> n (* 2 kilo)) - (list (/ n kilo) (if imply-bytes "K" "KB"))) - (t (list n (if imply-bytes "" " bytes"))))))) - -;; WARNING: This function may or may not work on your Lisp system. It -;; all depends on how the OPEN function has been implemented regarding -;; the :IF-EXISTS option. This function requires that OPEN be -;; implemented in a way so that the checking of the existence of file -;; and its open attempt be atomic. If the Lisp OPEN first checks that -;; the file exists and then tries to open it, this function won't be -;; reliable. CMUCL seems to use the O_EXCL open() flag in the right -;; way. So at least on CMUCL this function will work. Same goes for -;; SBCL. -(defun make-lock-files (pathnames &key (sleep-time 7) retries (suspend 13) expiration) - "Create semaphore files. If it can't create all the specified -files in the specified order, it waits SLEEP-TIME seconds and -retries the last file that didn't succeed. You can specify the -number of RETRIES to do until failure is returned. If the number -of retries is NIL this function will retry forever. - -If it tries RETRIES times without success, this function signal -an error and removes all the lock files it created until then. - -All files created by lock file will be read-only. - -If you specify a EXPIRATION then an existing lock file will be -removed by force after EXPIRATION seconds have passed since the -lock file was last modified/created (most likely by some other -program that unexpectedly died without cleaning up its lock -files). After a lock file has been removed by force, a -suspension of SUSPEND seconds is taken into account, in order to -prevent the inadvertent immediate removal of any newly created -lock file by another program." - (be locked '() - (flet ((lock (file) - (when (and expiration - (> (get-universal-time) - (+ (file-write-date file) expiration))) - (delete-file file) - (when suspend - (sleep suspend))) - (do ((i 0 (1+ i)) - (done nil)) - (done) - (unless (or (not retries) - (< i retries)) - (error "Can't create lock file ~S: tried ~A time~:P." file retries)) - (with-open-file (out file :direction :output :if-exists nil) - (cond (out - (format out "Lock file created on ~A~%" (time-string (get-universal-time))) - (setf done t)) - (sleep-time - (sleep sleep-time))))))) - (unwind-protect - (progn - (dolist (file pathnames) - (lock file) - (push file locked)) - (setf locked '())) - (mapc #'delete-file locked))))) - -(defmacro with-lock-files ((lock-files &rest lock-args) &body body) - "Execute BODY after creating LOCK-FILES. Remove the lock files -on exit. LOCK-ARGS are passed to MAKE-LOCK-FILES." - (with-gensyms (files) - `(be ,files (list ,@lock-files) - (make-lock-files ,files ,@lock-args) - (unwind-protect (progn ,@body) - (mapc #'delete-file ,files))))) - -(defun getpid () - #+cmu (unix:unix-getpid) - #+sbcl (sb-unix:unix-getpid) - #+clisp (ext:process-id) - #-(or cmu sbcl clisp) - (error "getpid unsupported under this Lisp implementation")) - -(defmacro on-error (form &body error-forms) - "Execute FORM and in case of error execute ERROR-FORMS too. -This does _not_ stop the error from propagating." - (be done-p (gensym) - `(be ,done-p nil - (unwind-protect - (prog1 - ,form - (setf ,done-p t)) - (unless ,done-p - ,@error-forms))))) - -(defun floor-to (x aim) - "Round X down to the nearest multiple of AIM." - (* (floor x aim) aim)) - -(defun round-to (x aim) - "Round X to the nearest multiple of AIM." - (* (round x aim) aim)) - -(defun ceiling-to (x aim) - "Round X up to the nearest multiple of AIM." - (* (ceiling x aim) aim)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct queue - first - last) - -(defgeneric queue-append (queue objects)) -(defgeneric queue-pop (queue)) -(defgeneric queue-empty-p (queue)) - -(defmethod queue-append ((queue queue) (objects list)) - (cond ((null (queue-first queue)) - (setf (queue-first queue) objects - (queue-last queue) (last objects))) - (t - (setf (cdr (queue-last queue)) objects - (queue-last queue) (last objects)))) - queue) - -(defmethod queue-append ((queue queue) object) - (queue-append queue (list object))) - -(defmethod queue-pop ((queue queue)) - (prog1 (car (queue-first queue)) - (setf (queue-first queue) (cdr (queue-first queue))))) - -(defmethod queue-empty-p ((queue queue)) - (null (queue-first queue))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun package-locked-p (package) - #+sbcl (sb-ext:package-locked-p package) - #+cmu (ext:package-definition-lock package) - #+clisp (ext:package-lock package) - #-(or sbcl cmu clisp) (error "Don't know how to check whether a package might be locked.")) - -(defun forget-documentation (packages) - "Remove documentation from all known symbols in PACKAGES. If -PACKAGES is NIL remove documentations from all packages. This may not -make sense if your Lisp image has been built so that existing objects -don't get garbage collected. It may work for your own code, though. -Locked packages are left alone. If you need to do those too, unlock -them first." - (flet ((forget (symbol) - (dolist (type '(compiler-macro function method-combination setf structure type variable)) - (when (ignore-errors (documentation symbol type)) - (setf (documentation symbol type) nil))))) - (setf packages (mapcar #'(lambda (pkg) - (if (packagep pkg) - (package-name pkg) - (package-name (find-package pkg)))) - packages)) - (setf packages - ;; don't try to modify locked packages - (remove-if #'package-locked-p - (mapcar #'find-package - (or packages - (list-all-packages))))) - (dolist (package packages) - (with-package-iterator (next package :internal :external) - (loop - (multiple-value-bind (more? symbol) (next) - (unless more? - (return)) - (forget symbol))))) - #+(OR) (do-all-symbols (symbol) - (when (member (symbol-package symbol) packages) - (forget symbol)))) - (values)) - -(defun load-compiled (pathname &optional compiled-pathname) - "Make sure to compile PATHNAME before loading it. Don't compile if -the compiled version is more recent than its source." - ;; be tolerant if we didn't get a type - (unless (probe-file pathname) - (setf pathname (merge-pathnames pathname (make-pathname :type "lisp")))) - (if (probe-file pathname) - (progn - (setf compiled-pathname (or compiled-pathname - (compile-file-pathname pathname))) - (when (or (not (probe-file compiled-pathname)) - (< (file-write-date compiled-pathname) - (file-write-date pathname))) - (compile-file pathname)) - (load compiled-pathname)) - (error "Can't load ~A as it doesn't exist." pathname))) - -;; Just a silly mnemonic for those used to lesser languages -(defmacro swap (x y) - "Swap values of places X and Y." - `(rotatef ,x ,y)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro show (&rest things) - "Debugging macro to show the name and content of variables. You can -also specify forms, not just variables." - (let ((*print-pretty* nil)) - `(let ((*print-circle* t)) - (format t ,(format nil "~~&~{~A=~~:W~~%~}" things) - ,@things) - (finish-output) - (values)))) - -(defmacro memoize-function (name &key test) - "Make function NAME memoized. TEST is passed to MAKE-HASH-TABLE." - `(setf (get ',name 'results-hash-table) - (make-hash-table ,@(when test (list :test test))))) - -(defmacro defun-memoized (name args &body forms) - "Define function NAME and make it memoizable. Then the MEMOIZED -macro can be used to call this function and memoize its results. The -function NAME must accept only one argument and return just one -argument; more complicated cases are not considered. The hash table -test function is the default 'EQL." - `(eval-when (:load-toplevel :compile-toplevel) - (defun ,name ,args ,@forms) - (memoize-function ,name))) - -(defmacro memoized (function arg) - "If necessary call FUNCTION passing ARG so that its return value is -memoized. The next time this form is executed with the same argument -value, the memoized result is returned instead of executing FUNCTION." - (with-gensyms (table key result not-found) - `(be* ,key ,arg - ,table (get ',function 'results-hash-table) - ,not-found (list nil) - ,result (gethash ,key ,table ,not-found) - (if (eq ,not-found ,result) - (setf (gethash ,key ,table) - (,function ,key)) - ,result)))) - - -(defmacro save-file-excursion ((stream &optional position) &body forms) - "Execute FORMS returning, on exit, STREAM to the position it was -before FORMS. Optionally POSITION can be set to the starting offset." - (unless position - (setf position (gensym))) - `(be ,position (file-position ,stream) - (unwind-protect (progn ,@forms) - (file-position ,stream ,position)))) - -(defun circular-list (&rest elements) - "Return a circular list of ELEMENTS." - (setf (cdr (last elements)) elements)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun getenv (var) - "Return the string associate to VAR in the system environment." - #+cmu (cdr (assoc (if (symbolp var) - var - (intern var :keyword)) - ext:*environment-list*)) - #+sbcl (sb-ext:posix-getenv (string var)) - #+lispworks (hcl:getenv var) - #+clisp (ext:getenv (string var)) - #-(or cmu sbcl lispworks clisp) - (error "GETENV not implemented for your Lisp system.")) - -#+clisp (ffi:def-call-out %setenv - (:name "setenv") - (:arguments (name ffi:c-string) (value ffi:c-string) (overwrite ffi:int)) - (:return-type ffi:int) - (:library "libc.so")) - -#+clisp (ffi:def-call-out %unsetenv - (:name "unsetenv") - (:arguments (name ffi:c-string)) - (:return-type ffi:int) - (:library "libc.so")) - -(defun setenv (name value &optional (overwrite t)) - (typecase value - (string) - (pathname - (setf value (native-namestring value))) - (t - (setf value (format nil "~A" value)))) - #+sbcl (unless (zerop (sb-posix:setenv name value (if overwrite 1 0))) - (error "unable to setenv ~A: errno=~A." name - (sb-alien:get-errno))) - #+cmu (be key (keywordify name) - (aif (assoc key - ext:*environment-list*) - (when overwrite - (setf (cdr it) value)) - (setf ext:*environment-list* - (cons (cons key value) - ext:*environment-list*)))) - #-(or cmu sbcl) (unless (zerop (%setenv name value (if overwrite 1 0))) - (error "unable to setenv ~A." name))) - -(defun unsetenv (name) - #+sbcl (unless (zerop (sb-posix:unsetenv name)) - (error "unable to unsetenv ~A: errno=~A." name - (sb-alien:get-errno))) - #+cmu (be key (keywordify name) - (setf ext:*environment-list* - (delete-if #'(lambda (e) - (eq (car e) key)) - ext:*environment-list*))) - #-(or cmu sbcl) (unless (zerop (%unsetenv name)) - (error "unable to unsetenv ~A." name))) - -(defun (setf getenv) (value name) - (if value - (setenv name value t) - (unsetenv name))) - -;; in CMUCL it's much easier (see below) -#-cmu -(defmacro with-system-environment ((&rest var-and-values) &body body) - (be gensym-alist (mapcar #'(lambda (vv) - (list (gensym) (string (car vv)) (cadr vv))) - var-and-values) - `(let ,(mapcar #'(lambda (vv) - (destructuring-bind (varsym var value) vv - (declare (ignore value)) - `(,varsym (getenv ,var)))) - gensym-alist) - (unwind-protect - (progn - ,@(mapcar #'(lambda (vv) - (destructuring-bind (varsym var value) vv - (declare (ignore varsym)) - `(setenv ,var ,value))) - gensym-alist) - ,@body) - ,@(mapcar #'(lambda (vv) - (destructuring-bind (varsym var value) vv - (declare (ignore value)) - `(if ,varsym - (setenv ,var ,varsym) - (unsetenv ,var)))) - gensym-alist))))) - -#+cmu -(defmacro with-system-environment ((&rest var-and-values) &body body) - `(let ((ext:*environment-list* - (append (list ,@(mapcar #'(lambda (vv) - (destructuring-bind (variable value) vv - `(cons ,(keywordify variable) - ,value))) - var-and-values)) - ext:*environment-list*))) - ,@body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun last-member (item list &key key (test #'eq)) - "Return the last sublist in LIST that is prefixed by ITEM." - (loop - with l = list and result = nil - for l2 = (member item l :key key :test test) - while l2 - do (setf result l2 - l (cdr l2)) - finally (return result))) - - -(defun glob->regex (string) - "Convert a shell glob expression into a regular expression string." - (with-output-to-string (out) - ;; globs are always anchored to beginning and end - (write-char #\^ out) - (loop - for i from 0 below (length string) - do (be c (char string i) - (cond ((char= c #\\) - (setf c (char string (incf i)))) - ((find c ".+()|^$") - (write-char #\\ out)) - ((char= c #\*) - (write-char #\. out)) - ((char= c #\?) - (setf c #\.))) - (write-char c out))) - (write-char #\$ out))) diff --git a/third_party/lisp/sclf/serial.lisp b/third_party/lisp/sclf/serial.lisp deleted file mode 100644 index 41d32e4c49fd..000000000000 --- a/third_party/lisp/sclf/serial.lisp +++ /dev/null @@ -1,62 +0,0 @@ - ;;; serial.lisp --- serialisation of CLOS objects - - ;;; Copyright (C) 2009 by Walter C. Pelissero - - ;;; Author: Walter C. Pelissero <walter@pelissero.de> - ;;; Project: sclf - -#+cmu (ext:file-comment "$Module: serial.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -(in-package :sclf) - -(defclass printable-object-mixin () ()) - -(defmacro reconstruct-object (class &rest args) - `(apply #'make-instance ',class ',args)) - -(defun print-readable-instance (object &optional stream) - (unless stream - (setf stream *standard-output*)) - (be class (class-of object) - (pprint-logical-block (stream (copy-list (class-slots class)) :prefix "#.(" :suffix ")") - (flet ((spc () - (write-char #\space stream))) - (write 'reconstruct-object :stream stream) - (spc) - (write (class-name class) :stream stream :escape t :readably t :pretty t) - (pprint-exit-if-list-exhausted) - (spc) - (loop - (be* slot (pprint-pop) - slot-name (slot-definition-name slot) - initarg (car (slot-definition-initargs slot)) - (when (and initarg - (slot-boundp object slot-name)) - (write initarg :stream stream) - (spc) - (when *print-pretty* - (pprint-newline :miser stream)) - (write (slot-value object slot-name) - :stream stream) - (pprint-exit-if-list-exhausted) - (if *print-pretty* - (pprint-newline :linear stream) - (spc))))))))) - -(defmethod print-object ((object printable-object-mixin) stream) - (if *print-readably* - (print-readable-instance object stream) - (call-next-method))) diff --git a/third_party/lisp/sclf/sysproc.lisp b/third_party/lisp/sclf/sysproc.lisp deleted file mode 100644 index 1dd559ebe3a2..000000000000 --- a/third_party/lisp/sclf/sysproc.lisp +++ /dev/null @@ -1,295 +0,0 @@ -;;; sysproc.lisp --- system processes - -;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: sclf - -#+cmu (ext:file-comment "$Module: sysproc.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -(in-package :sclf) - -(defvar *bourne-shell* "/bin/sh") - -(defvar *run-verbose* nil - "If true system commands are displayed before execution and standard -error is not discarded.") - -;; -;; SIGINFO is missing in both CMUCL and SBCL -;; - -#+cmu -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant unix::siginfo 29) - (defvar siginfo (unix::make-unix-signal :siginfo unix::siginfo "Information")) - (export '(unix::siginfo) "UNIX") - (pushnew siginfo unix::*unix-signals*)) - -#+sbcl (in-package :sb-posix) -#+sbcl -(eval-when (:execute :compile-toplevel :load-toplevel) - (unless (find-symbol "SIGINFO" :sb-posix) - (sb-ext:with-unlocked-packages (:sb-posix) - (defvar siginfo 29) - (export '(SIGINFO))))) -#+sbcl (in-package :sclf) - -(defun signal-number (signal-name) - (ecase signal-name - ((:abrt :abort) - #+cmu unix:sigabrt - #+sbcl sb-posix:sigabrt) - ((:alrm :alarm) - #+cmu unix:sigalrm - #+sbcl sb-posix:sigalrm) - ((:bus :bus-error) - #+cmu unix:sigbus - #+sbcl sb-posix:sigbus) - ((:chld :child) - #+cmu unix:sigchld - #+sbcl sb-posix:sigchld) - ((:cont :continue) - #+cmu unix:sigcont - #+sbcl sb-posix:sigcont) - #+freebsd((:emt :emulate-instruction) - #+cmu unix:sigemt - #+sbcl sb-posix:sigemt) - ((:fpe :floating-point-exception) - #+cmu unix:sigfpe - #+sbcl sb-posix:sigfpe) - ((:hup :hangup) - #+cmu unix:sighup - #+sbcl sb-posix:sighup) - ((:ill :illegal :illegal-instruction) - #+cmu unix:sigill - #+sbcl sb-posix:sigill) - ((:int :interrupt) - #+cmu unix:sigint - #+sbcl sb-posix:sigint) - ((:io :input-output) - #+cmu unix:sigio - #+sbcl sb-posix:sigio) - (:kill - #+cmu unix:sigkill - #+sbcl sb-posix:sigkill) - ((:pipe :broke-pipe) - #+cmu unix:sigpipe - #+sbcl sb-posix:sigpipe) - ((:prof :profiler) - #+cmu unix:sigprof - #+sbcl sb-posix:sigprof) - (:quit - #+cmu unix:sigquit - #+sbcl sb-posix:sigquit) - ((:segv :segmentation-violation) - #+cmu unix:sigsegv - #+sbcl sb-posix:sigsegv) - (:stop - #+cmu unix:sigstop - #+sbcl sb-posix:sigstop) - ((:sys :system-call) - #+cmu unix:sigsys - #+sbcl sb-posix:sigsys) - ((:term :terminate) - #+cmu unix:sigterm - #+sbcl sb-posix:sigterm) - ((:trap) - #+cmu unix:sigtrap - #+sbcl sb-posix:sigtrap) - ((:tstp :terminal-stop) - #+cmu unix:sigtstp - #+sbcl sb-posix:sigtstp) - ((:ttin :tty-input) - #+cmu unix:sigttin - #+sbcl sb-posix:sigttin) - ((:ttou :tty-output) - #+cmu unix:sigttou - #+sbcl sb-posix:sigttou) - ((:urg :urgent) - #+cmu unix:sigurg - #+sbcl sb-posix:sigurg) - ((:usr1 :user1) - #+cmu unix:sigusr1 - #+sbcl sb-posix:sigusr1) - ((:usr2 :user2) - #+cmu unix:sigusr2 - #+sbcl sb-posix:sigusr2) - ((:vtalrm :virtual-timer-alarm) - #+cmu unix:sigvtalrm - #+sbcl sb-posix:sigvtalrm) - ((:winch :window-change :window-size-change) - #+cmu unix:sigwinch - #+sbcl sb-posix:sigwinch) - ((:xcpu :exceeded-cpu) - #+cmu unix:sigxcpu - #+sbcl sb-posix:sigxcpu) - ((:xfsz :exceeded-file-size) - #+cmu unix:sigxfsz - #+sbcl sb-posix:sigxfsz) - ;; oddly this is not defined by neither CMUCL nor SBCL - (:info 29))) - -(defun sysproc-kill (process signal) - (when (keywordp signal) - (setf signal (signal-number signal))) - #+cmu (ext:process-kill process signal) - #+sbcl (sb-ext:process-kill process signal) - #-(or sbcl cmu) (error "Don't know how to kill a process")) - -(defun sysproc-exit-code (process) - #+cmu (ext:process-exit-code process) - #+sbcl (sb-ext:process-exit-code process) - #-(or sbcl cmu) (error "Don't know how to get a process exit code")) - -(defun sysproc-wait (process) - #+cmu (ext:process-wait process) - #+sbcl (sb-ext:process-wait process) - #-(or sbcl cmu) (error "Don't know how to wait a process")) - -(defun sysproc-input (process) - #+cmu (ext:process-input process) - #+sbcl (sb-ext:process-input process) - #-(or sbcl cmu) (error "Don't know how to get the process input")) - -(defun sysproc-output (process) - #+cmu (ext:process-output process) - #+sbcl (sb-ext:process-output process) - #-(or sbcl cmu) (error "Don't know how to get the process output")) - -(defun sysproc-alive-p (process) - #+cmu (ext:process-alive-p process) - #+sbcl (sb-ext:process-alive-p process) - #-(or sbcl cmu) (error "Don't know how to test wether a process might be running")) - -(defun sysproc-pid (process) - #+cmu (ext:process-pid process) - #+sbcl (sb-ext:process-pid process) - #-(or sbcl cmu) (error "Don't know how to get the id of a process")) - -(defun sysproc-p (thing) - #+sbcl (sb-ext:process-p thing) - #+cmu (ext:process-p thing) - #-(or sbcl cmu) (error "Don't know how to figure out whether something is a system process")) - -(defun run-program (program arguments &key (wait t) pty input output error) - "Run PROGRAM with ARGUMENTS (a list) and return a process object." - ;; convert arguments to strings - (setf arguments - (mapcar #'(lambda (item) - (typecase item - (string item) - (pathname (native-namestring item)) - (t (format nil "~A" item)))) - arguments)) - (when *run-verbose* - (unless error - (setf error t)) - (format t "~&; run-pipe ~A~{ ~S~}~%" program arguments)) - #+cmu (ext:run-program program arguments - :wait wait - :pty pty - :input input - :output output - :error (or error *run-verbose*)) - #+sbcl (sb-ext:run-program program arguments - :search t - :wait wait - :pty pty - :input input - :output output - :error (or error *run-verbose*)) - #-(or sbcl cmu) - (error "Unsupported Lisp system.")) - -(defun run-pipe (direction program arguments &key error) - "Run PROGRAM with a list of ARGUMENTS and according to DIRECTION -return the input and output streams and process object of that -process." - (be process (run-program program arguments - :wait nil - :pty nil - :input (when (member direction '(:output :input-output :io)) - :stream) - :output (when (member direction '(:input :input-output :io)) - :stream) - :error error) - (values (sysproc-output process) - (sysproc-input process) - process)) - #-(or sbcl cmu) - (error "Unsupported Lisp system.")) - -(defun exit-code (process) - (sysproc-wait process) - (sysproc-exit-code process)) - -(defun run-shell-command (fmt &rest args) - "Run a Bourne Shell command. Return the exit status of the command." - (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args)))) - -(defun run-async-shell-command (fmt &rest args) - "Run a Bourne Shell command asynchronously. Return a process -object if provided by your Lisp implementation." - (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args)) - :wait nil)) - -(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms) - "Run BODY with IN and OUT bound respectively to an input and an -output stream connected to a system process created by running PROGRAM -with ARGUMENTS. If IN or OUT are NIL, then don't create that stream." - (with-gensyms (prg args) - `(be* ,prg ,program - ,args ,arguments - ,process (run-program ,prg ,args - :output ,(case in - ((t nil) in) - (t :stream)) - :input ,(case out - ((t nil) out) - (t :stream)) - :wait nil - :pty ,pty - ,@(when error `(:error ,error))) - (if ,process - (let (,@(case in - ((t nil)) - (t `((,in (sysproc-output ,process))))) - ,@(case out - ((t nil)) - (t `((,out (sysproc-input ,process)))))) - (unwind-protect - (progn - ,@forms) - ,@(case in - ((t nil)) - (t `((close ,in)))) - ,@(case out - ((t nil)) - (t `((close ,out)))) - (when (sysproc-alive-p ,process) - (sysproc-kill ,process :term)))) - (error "unable to run ~A~{ ~A~}." ,prg ,args))))) - - -(defun sysproc-set-signal-callback (signal handler) - "Arrange HANDLER function to be called when receiving the system -signal SIGNAL." - (when (keywordp signal) - (setf signal (signal-number signal))) - #+cmu (system:enable-interrupt signal handler) - #+sbcl (sb-sys:enable-interrupt signal handler) - #-(or cmu sbcl) (error "Don't know how to set a system signal callback.")) diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp deleted file mode 100644 index 71b943aa431a..000000000000 --- a/third_party/lisp/sclf/time.lisp +++ /dev/null @@ -1,311 +0,0 @@ -;;; time.lisp --- time primitives - -;;; Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: sclf - -#+cmu (ext:file-comment "$Module: time.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -(in-package :sclf) - -(defun year (epoch &optional time-zone) - "Return the year of EPOCH." - (sixth (multiple-value-list (decode-universal-time epoch time-zone)))) - -(defun month (epoch &optional time-zone) - "Return the month of EPOCH." - (fifth (multiple-value-list (decode-universal-time epoch time-zone)))) - -(defun day (epoch &optional time-zone) - "Return the day of EPOCH." - (fourth (multiple-value-list (decode-universal-time epoch time-zone)))) - -(defun week-day (epoch &optional time-zone) - "Return the day of the week of EPOCH." - (seventh (multiple-value-list (decode-universal-time epoch time-zone)))) - -(defun hour (epoch &optional time-zone) - "Return the hour of EPOCH." - (third (multiple-value-list (decode-universal-time epoch time-zone)))) - -(defun minute (epoch &optional time-zone) - "Return the minute of EPOCH." - (second (multiple-value-list (decode-universal-time epoch time-zone)))) - -(defun leap-year-p (year) - "Return true if YEAR is a leap year." - (and (zerop (mod year 4)) - (or (not (zerop (mod year 100))) - (zerop (mod year 400))))) - -(defun last-day-of-month (month year) - "Return the last day of the month as integer." - (be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)) - (if (and (= last 28) - (leap-year-p year)) - (1+ last) - last))) - -(defun add-months (months epoch &optional time-zone) - "Add MONTHS to EPOCH, which is a universal time. MONTHS can be -negative." - (multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone) - (multiple-value-bind (y m) (floor (+ month months -1) 12) - (let ((new-month (1+ m)) - (new-year (+ year y))) - (encode-universal-time ss mm hh - (min day (last-day-of-month new-month (year epoch))) - new-month - new-year - time-zone))))) - -(defun add-days (days epoch) - "Add DAYS to EPOCH, which is an universal time. DAYS can be -negative." - (+ (* 60 60 24 days) epoch)) - -;; The following two functions are based on Thomas Russ <tar@isi.edu> -;; code which didn't carry any copyright notice, so I assume it was in -;; the public domain. - -(defun iso-time-string (time &key time-zone with-timezone-p basic) - "Return an ISO 8601 string representing TIME. The time zone is -included if WITH-TIMEZONE-P is true." - (flet ((format-timezone (zone) - (if (zerop zone) - "Z" - (multiple-value-bind (h m) (truncate (abs zone) 1.0) - ;; Sign of time zone is reversed in ISO 8601 relative - ;; to Common Lisp convention! - (format nil "~:[+~;-~]~2,'0D:~2,'0D" - (> zone 0) h (round m)))))) - (multiple-value-bind (second minute hour day month year dow dst zone) - (decode-universal-time time time-zone) - (declare (ignore dow dst)) - (if basic - (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]" - year month day hour minute second - with-timezone-p (format-timezone zone)) - (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" - year month day hour minute second - with-timezone-p (format-timezone zone)))))) - -(defun parse-iso-time-string (time-string) - "Parse an ISO 8601 formated string and return the universal time. -It can parse the basic and the extended format, but may not be able to -cover all the cases." - (labels ((parse-delimited-string (string delimiter n) - ;; Parses a delimited string and returns a list of - ;; n integers found in that string. - (let ((answer (make-list n :initial-element 0))) - (loop - for i upfrom 0 - for start = 0 then (1+ end) - for end = (position delimiter string :start (1+ start)) - do (setf (nth i answer) - (parse-integer (subseq string start end))) - when (null end) return t) - (values-list answer))) - (parse-fixed-field-string (string field-sizes) - ;; Parses a string with fixed length fields and returns - ;; a list of integers found in that string. - (let ((answer (make-list (length field-sizes) :initial-element 0))) - (loop - with len = (length string) - for start = 0 then (+ start field-size) - for field-size in field-sizes - for i upfrom 0 - while (< start len) - do (setf (nth i answer) - (parse-integer (subseq string start (+ start field-size))))) - (values-list answer))) - (parse-iso8601-date (date-string) - (let ((hyphen-pos (position #\- date-string))) - (if hyphen-pos - (parse-delimited-string date-string #\- 3) - (parse-fixed-field-string date-string '(4 2 2))))) - (parse-iso8601-timeonly (time-string) - (let* ((colon-pos (position #\: time-string)) - (zone-pos (or (position #\- time-string) - (position #\+ time-string))) - (timeonly-string (subseq time-string 0 zone-pos)) - (zone-string (when zone-pos (subseq time-string (1+ zone-pos)))) - (time-zone nil)) - (when zone-pos - (multiple-value-bind (zone-h zone-m) - (parse-delimited-string zone-string #\: 2) - (setq time-zone (+ zone-h (/ zone-m 60))) - (when (char= (char time-string zone-pos) #\-) - (setq time-zone (- time-zone))))) - (multiple-value-bind (hh mm ss) - (if colon-pos - (parse-delimited-string timeonly-string #\: 3) - (parse-fixed-field-string timeonly-string '(2 2 2))) - (values hh mm ss time-zone))))) - (let ((time-separator (position #\T time-string))) - (multiple-value-bind (year month date) - (parse-iso8601-date - (subseq time-string 0 time-separator)) - (if time-separator - (multiple-value-bind (hh mm ss zone) - (parse-iso8601-timeonly - (subseq time-string (1+ time-separator))) - (if zone - ;; Sign of time zone is reversed in ISO 8601 - ;; relative to Common Lisp convention! - (encode-universal-time ss mm hh date month year (- zone)) - (encode-universal-time ss mm hh date month year))) - (encode-universal-time 0 0 0 date month year)))))) - -(defun time-string (time &optional time-zone) - "Return a string representing TIME in the form: - Tue Jan 25 12:55:40 2005" - (multiple-value-bind (ss mm hh day month year week-day) - (decode-universal-time time time-zone) - (format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A" - (subseq (week-day->string week-day) 0 3) - (subseq (month->string month) 0 3) - day - hh mm ss - year))) - -(defun beginning-of-month (month year &optional time-zone) - (encode-universal-time 0 0 0 1 month year time-zone)) - -(defun end-of-month (month year &optional time-zone) - (1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone)))) - -(defun beginning-of-first-week (year &optional time-zone) - "Return the epoch of the first week of YEAR. As the first week -of the year needs to have Thursday in this YEAR, the returned -time can actually fall in the previous year." - (let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone)) - (start (- 4 (week-day (add-days 4 Jan-1st))))) - (add-days start Jan-1st))) - -(defun beginning-of-week (week year &optional time-zone) - "Return the epoch of the beginning of WEEK of YEAR." - (add-days (* (1- week) 7) (beginning-of-first-week year time-zone))) - -(defun end-of-week (week year &optional time-zone) - "Return the epoch of the beginning of WEEK of YEAR." - (1- (beginning-of-week (1+ week) year time-zone))) - -(defun end-of-last-week (year &optional time-zone) - "Return the epoch of the last week of YEAR. As the last week -of the year needs to have Thursday in this YEAR, the returned -time can fall in the next year." - (1- (beginning-of-first-week (1+ year) time-zone))) - -(defun seconds-from-beginning-of-the-year (time &optional time-zone) - (- time (encode-universal-time 0 0 0 1 1 (year time) time-zone))) - -(defun day-of-the-year (time &optional time-zone) - "Return the day within the year of TIME starting from 1 up to -365 (or 366)." - (1+ (truncate (seconds-from-beginning-of-the-year time time-zone) - (* 60 60 24)))) - -(defun week (time &optional time-zone) - "Return the number of the week and the year TIME referes to. -Week is an integer from 1 to 52. Due to the way the first week -of the year is calculated a day in one year could actually be in -the last week of the previous or next year." - (let* ((year (year time)) - (start (beginning-of-first-week year time-zone)) - (days-from-start (truncate (- time start) (* 60 60 24))) - (weeks (truncate days-from-start 7)) - (week-number (mod weeks 52))) - (values (1+ week-number) - (cond ((< weeks 0) - (1- year)) - ((> weeks 51) - (1+ year)) - (t year))))) - -(defun week-day->string (day &optional sunday-first) - "Return the weekday string corresponding to DAY number." - (elt (if sunday-first - #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") - #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) - day)) - -(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July" - "August" "September" "October" "November" "December")) - -(defun month->string (month) - "Return the month string corresponding to MONTH number." - (elt +month-names+ (1- month))) - -(defun month-string->number (month) - (1+ (position month +month-names+ :test #'string-equal))) - -(defun print-time-span (span &optional stream) - "Print in English the time SPAN expressed in seconds." - (let* ((minute 60) - (hour (* minute 60)) - (day (* hour 24)) - (seconds span)) - (macrolet ((split (divisor) - `(when (>= seconds ,divisor) - (prog1 (truncate seconds ,divisor) - (setf seconds (mod seconds ,divisor)))))) - (let* ((days (split day)) - (hours (split hour)) - (minutes (split minute))) - (format stream "~{~A~^ ~}" (remove nil - (list - (when days - (format nil "~D day~:P" days)) - (when hours - (format nil "~D hour~:P" hours)) - (when minutes - (format nil "~D minute~:P" minutes)) - (when (or (> seconds 0) - (= span 0)) - (format nil "~D second~:P" seconds))))))))) - -(defun next-week-day (epoch week-day &optional time-zone) - "Return the universal time of the next WEEK-DAY starting from epoch." - (add-days (mod (- week-day (week-day epoch time-zone)) 7) - epoch)) - -(defun next-monday (epoch &optional time-zone) - "Return the universal time of the next Monday starting from -EPOCH." - (next-week-day epoch 0 time-zone)) - -(defun full-weeks-in-span (start end &optional time-zone) - "Return the number of full weeks in time span START to END. A -full week starts on Monday and ends on Sunday." - (be first-monday (next-monday start time-zone) - (truncate (- end first-monday) (* 7 24 60 60)))) - -(defconst +unix-lisp-time-difference+ - (encode-universal-time 0 0 0 1 1 1970 0) - "Time difference between Unix epoch and Common Lisp epoch. The -former is 1st January 1970, while the latter is the beginning of the -XX century.") - -(defun universal->unix-time (time) - (- time +unix-lisp-time-difference+)) - -(defun unix->universal-time (time) - (+ time +unix-lisp-time-difference+)) - -(defun get-unix-time () - (universal->unix-time (get-universal-time))) |