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