mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore: remove sclf from the tree

Browse source 
SCLF is quite a big utility library (almost 3€ LOC) with limited
portability (CMUCL, SBCL and CLISP to an extent). Continuing to maintain
it is an unnecessary burden, as depot only uses a fraction of it which
is now inlined into the respective users (mime4cl and mblog).

In the future trimming down ex-sclf.lisp may make sense either by
refactoring the code that uses it or by moving interesting utilities
into e.g. klatre.

Change-Id: I2e73825b6bfa372e97847f25c30731a5aad4a1b5
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5922
Tested-by: BuildkiteCI
Autosubmit: sterni <sternenseemann@systemli.org>
Reviewed-by: sterni <sternenseemann@systemli.org>
This commit is contained in:
sterni 2022-07-04 15:56:52 +02:00 committed by clbot
parent c08e47903e
commit 49aee7a8f2
24 changed files with 488 additions and 3646 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
third_party/lisp/mime4cl/default.nix vendored
View file

@ -7,12 +7,12 @@ depot.nix.buildLisp.library {
deps = [
depot.third_party.lisp.babel
depot.third_party.lisp.sclf
depot.third_party.lisp.npg
depot.third_party.lisp.trivial-gray-streams
];
srcs = [
./ex-sclf.lisp
./package.lisp
./endec.lisp
./streams.lisp
@ -34,6 +34,7 @@ depot.nix.buildLisp.library {
;; override auto discovery which doesn't work in store
(defvar *sample1-file* (pathname "${./test/sample1.msg}"))
'')
./test/temp-file.lisp
./test/endec.lisp
./test/address.lisp
./test/mime.lisp

393
third_party/lisp/mime4cl/ex-sclf.lisp vendored Normal file
View file

@ -0,0 +1,393 @@
;;; ex-sclf.lisp --- subset of sclf used by mime4cl
;;; Copyright (C) 2005-2010 by Walter C. Pelissero
;;; Copyright (C) 2022 The TVL Authors
;;; Author: sternenseemann <sternenseemann@systemli.org>
;;; Project: mime4cl
;;;
;;; mime4cl uses sclf for miscellaneous utility functions. sclf's portability
;;; is quite limited. Since mime4cl is the only thing in TVL's depot depending
;;; on sclf, it made more sense to strip down sclf to the extent mime4cl needed
;;; in order to lessen the burden of porting it to other CL implementations
;;; later.
;;;
;;; Eventually it probably makes sense to drop the utilities we don't like and
;;; merge the ones we do like into depot's own utility package, klatre.
#+cmu (ext:file-comment "$Module: ex-sclf.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(defpackage :mime4cl-ex-sclf
(:use :common-lisp)
(:export
#:be
#:be*
#:aif
#:awhen
#:aand
#:it
#:gcase
#:with-gensyms
#:split-at
#:split-string-at-char
#:+whitespace+
#:whitespace-p
#:string-concat
#:s+
#:string-starts-with
#:string-trim-whitespace
#:string-left-trim-whitespace
#:string-right-trim-whitespace
#:queue
#:make-queue
#:queue-append
#:queue-pop
#:queue-empty-p
#:save-file-excursion
#:read-file
#:unix-file-stat
#:unix-stat
#:file-size
#:promise
#:make-promise
#:lazy
#:force
#:forced-p
#:deflazy
#:f++
#:week-day->string
#:month->string))
(in-package :mime4cl-ex-sclf)
;; MACRO UTILS
(defmacro with-gensyms ((&rest symbols) &body body)
"Gensym all SYMBOLS and make them available in BODY.
See also LET-GENSYMS."
`(let ,(mapcar #'(lambda (s)
(list s '(gensym))) symbols)
,@body))
;; CONTROL FLOW
(defmacro be (&rest bindings-and-body)
"Less-parenthetic let."
(let ((bindings
(loop
while (and (symbolp (car bindings-and-body))
(cdr bindings-and-body))
collect (list (pop bindings-and-body)
(pop bindings-and-body)))))
`(let ,bindings
,@bindings-and-body)))
(defmacro be* (&rest bindings-and-body)
"Less-parenthetic let*."
(let ((bindings
(loop
while (and (symbolp (car bindings-and-body))
(cdr bindings-and-body))
collect (list (pop bindings-and-body)
(pop bindings-and-body)))))
`(let* ,bindings
,@bindings-and-body)))
(defmacro aif (test then &optional else)
`(be it ,test
(if it
,then
,else)))
(defmacro awhen (test &body then)
`(be it ,test
(when it
,@then)))
(defmacro aand (&rest args)
(cond ((null args) t)
((null (cdr args)) (car args))
(t `(aif ,(car args) (aand ,@(cdr args))))))
(defmacro gcase ((value &optional (test 'equalp)) &rest cases)
"Generic CASE macro. Match VALUE to CASES as if by the normal CASE
but use TEST as the comparison function, which defaults to EQUALP."
(with-gensyms (val)
`(be ,val ,value
,(cons 'cond
(mapcar #'(lambda (case-desc)
(destructuring-bind (vals &rest forms) case-desc
`(,(cond ((consp vals)
(cons 'or (mapcar #'(lambda (v)
(list test val v))
vals)))
((or (eq vals 'otherwise)
(eq vals t))
t)
(t (list test val vals)))
,@forms)))
cases)))))
;; SEQUENCES
(defun position-any (bag sequence &rest position-args)
"Find any element of bag in sequence and return its position.
Accept any argument accepted by the POSITION function."
(apply #'position-if #'(lambda (element)
(find element bag)) sequence position-args))
(defun split-at (bag sequence &key (start 0) key)
"Split SEQUENCE at occurence of any element from BAG.
Contiguous occurences of elements from BAG are considered atomic;
so no empty sequence is returned."
(be len (length sequence)
(labels ((split-from (start)
(unless (>= start len)
(be sep (position-any bag sequence :start start :key key)
(cond ((not sep)
(list (subseq sequence start)))
((> sep start)
(cons (subseq sequence start sep)
(split-from (1+ sep))))
(t
(split-from (1+ start))))))))
(split-from start))))
;; STRINGS
(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page))
(defun whitespace-p (char)
(member char +whitespace+))
(defun string-trim-whitespace (string)
(string-trim +whitespace+ string))
(defun string-right-trim-whitespace (string)
(string-right-trim +whitespace+ string))
(defun string-left-trim-whitespace (string)
(string-left-trim +whitespace+ string))
(defun split-string-at-char (string separator &key escape skip-empty)
"Split STRING at SEPARATORs and return a list of the substrings. If
SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is
not nil then split at SEPARATOR only if it's not preceded by ESCAPE."
(declare (type string string) (type character separator))
(labels ((next-separator (beg)
(be pos (position separator string :start beg)
(if (and escape
pos
(plusp pos)
(char= escape (char string (1- pos))))
(next-separator (1+ pos))
pos)))
(parse (beg)
(cond ((< beg (length string))
(let* ((end (next-separator beg))
(substring (subseq string beg end)))
(cond ((and skip-empty (string= "" substring))
(parse (1+ end)))
((not end)
(list substring))
(t
(cons substring (parse (1+ end)))))))
(skip-empty
'())
(t
(list "")))))
(parse 0)))
(defun s+ (&rest strings)
"Return a string which is made of the concatenation of STRINGS."
(apply #'concatenate 'string strings))
(defun string-concat (list &optional (separator ""))
"Concatenate the strings in LIST interposing SEPARATOR (default
nothing) between them."
(reduce #'(lambda (&rest args)
(if args
(s+ (car args) separator (cadr args))
""))
list))
(defun string-starts-with (prefix string &optional (compare #'string=))
(be prefix-length (length prefix)
(and (>= (length string) prefix-length)
(funcall compare prefix string :end2 prefix-length))))
;; QUEUE
(defstruct queue
first
last)
(defgeneric queue-append (queue objects))
(defgeneric queue-pop (queue))
(defgeneric queue-empty-p (queue))
(defmethod queue-append ((queue queue) (objects list))
(cond ((null (queue-first queue))
(setf (queue-first queue) objects
(queue-last queue) (last objects)))
(t
(setf (cdr (queue-last queue)) objects
(queue-last queue) (last objects))))
queue)
(defmethod queue-append ((queue queue) object)
(queue-append queue (list object)))
(defmethod queue-pop ((queue queue))
(prog1 (car (queue-first queue))
(setf (queue-first queue) (cdr (queue-first queue)))))
(defmethod queue-empty-p ((queue queue))
(null (queue-first queue)))
;; STREAMS
(defmacro save-file-excursion ((stream &optional position) &body forms)
"Execute FORMS returning, on exit, STREAM to the position it was
before FORMS. Optionally POSITION can be set to the starting offset."
(unless position
(setf position (gensym)))
`(be ,position (file-position ,stream)
(unwind-protect (progn ,@forms)
(file-position ,stream ,position))))
(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default)
"Read the whole content of file and return it as a sequence which
can be a string, a vector of bytes, or whatever you specify as
ELEMENT-TYPE."
(with-open-file (in pathname
:element-type element-type
:if-does-not-exist (unless (eq :value if-does-not-exist)
:error))
(if in
(be seq (make-array (file-length in) :element-type element-type)
(read-sequence seq in)
seq)
default)))
;; FILES
(defun native-namestring (pathname)
#+sbcl (sb-ext:native-namestring pathname)
#-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
(namestring pathname)))
(defstruct (unix-file-stat (:conc-name stat-))
device
inode
links
atime
mtime
ctime
size
blksize
blocks
uid
gid
mode)
(defun unix-stat (pathname)
;; this could be different depending on the unix systems
(multiple-value-bind (ok? device inode mode links uid gid rdev
size atime mtime ctime
blksize blocks)
(#+cmu unix:unix-lstat
#+sbcl sb-unix:unix-lstat
;; TODO(sterni): ECL, CCL
(if (stringp pathname)
pathname
(native-namestring pathname)))
(declare (ignore rdev))
(when ok?
(make-unix-file-stat :device device
:inode inode
:links links
:atime atime
:mtime mtime
:ctime ctime
:size size
:blksize blksize
:blocks blocks
:uid uid
:gid gid
:mode mode))))
;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix
;; allows to get to know the file size without being able to open a
;; file; just ask politely.
(defun file-size (pathname)
(stat-size (unix-stat pathname)))
;; LAZY
(defstruct promise
procedure
value)
(defmacro lazy (form)
`(make-promise :procedure #'(lambda () ,form)))
(defun forced-p (promise)
(null (promise-procedure promise)))
(defun force (promise)
(if (forced-p promise)
(promise-value promise)
(prog1 (setf (promise-value promise)
(funcall (promise-procedure promise)))
(setf (promise-procedure promise) nil))))
(defmacro deflazy (name value &optional documentation)
`(defparameter ,name (lazy ,value)
,@(when documentation
(list documentation))))
;; FIXNUMS
(defmacro f++ (x &optional (delta 1))
"Same as INCF but hopefully optimised for fixnums."
`(setf ,x (+ (the fixnum ,x) (the fixnum ,delta))))
;; TIME
(defun week-day->string (day &optional sunday-first)
"Return the weekday string corresponding to DAY number."
(elt (if sunday-first
#("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")
#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
day))
(defvar +month-names+ #("January" "February" "March" "April" "May" "June" "July"
"August" "September" "October" "November" "December"))
(defun month->string (month)
"Return the month string corresponding to MONTH number."
(elt +month-names+ (1- month)))

2
third_party/lisp/mime4cl/mime.lisp vendored
View file

@ -702,7 +702,7 @@ body."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
"List of known content encodings.")
(defun keywordify-encoding (string)

8
third_party/lisp/mime4cl/package.lisp vendored
View file

@ -23,13 +23,7 @@
(defpackage :mime4cl
(:nicknames :mime)
(:use :common-lisp :npg :sclf :trivial-gray-streams)
;; this is stuff that comes from SCLF and clashes with CMUCL's EXT
;; package
(:shadowing-import-from :sclf
#:process-wait
#:process-alive-p
#:run-program)
(:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams)
(:import-from :babel :octets-to-string)
(:import-from :babel-encodings :get-character-encoding)
(:export #:*lazy-mime-decode*

4
third_party/lisp/mime4cl/test/endec.lisp vendored
View file

@ -139,9 +139,9 @@ line")
(declare (optimize (speed 3) (debug 0) (safety 0))
(type fixnum megs))
(with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
(let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*)
(let ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*)
:type "encoded-data")))
(sclf:with-temp-file (tmp nil :direction :io)
(with-temp-file (tmp nil :direction :io)
(let* ((meg (* 1024 1024))
(buffer (make-sequence '(vector (unsigned-byte 8)) meg))
(encoder-class (ecase decoder-class

2
third_party/lisp/mime4cl/test/package.lisp vendored
View file

@ -23,5 +23,5 @@
(defpackage :mime4cl-tests
(:use :common-lisp
:rtest :mime4cl)
:rtest :mime4cl :mime4cl-ex-sclf)
(:export))

72
third_party/lisp/mime4cl/test/temp-file.lisp vendored Normal file
View file

@ -0,0 +1,72 @@
;;; temp-file.lisp --- temporary file creation
;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
;;; Copyright (C) 2022 The TVL Authors
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
;;;
;;; Code taken from SCLF
#+cmu (ext:file-comment "$Module: temp-file.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :mime4cl-tests)
(defvar *tmp-file-defaults* #P"/tmp/")
(defun temp-file-name (&optional (default *tmp-file-defaults*))
"Create a random pathname based on DEFAULT. No effort is made
to make sure that the returned pathname doesn't identify an
already existing file. If missing DEFAULT defaults to
*TMP-FILE-DEFAULTS*."
(make-pathname :defaults default
:name (format nil "~36R" (random #.(expt 36 10)))))
(defun open-temp-file (&optional default-pathname &rest open-args)
"Open a new temporary file and return a stream to it. This function
makes sure the pathname of the temporary file is unique. OPEN-ARGS
are arguments passed verbatim to OPEN. If OPEN-ARGS specify
the :DIRECTION it should be either :OUTPUT (default) or :IO;
any other value causes an error. If DEFAULT-PATHNAME is specified and
not NIL it's used as defaults to produce the pathname of the temporary
file, otherwise *TMP-FILE-DEFAULTS* is used."
(unless default-pathname
(setf default-pathname *tmp-file-defaults*))
;; if :DIRECTION is specified check that it's compatible with the
;; purpose of this function, otherwise make it default to :OUTPUT
(aif (getf open-args :direction)
(unless (member it '(:output :io))
(error "Can't create temporary file with open direction ~A." it))
(setf open-args (append '(:direction :output)
open-args)))
(do* ((name #1=(temp-file-name default-pathname) #1#)
(stream #2=(apply #'open name
:if-exists nil
:if-does-not-exist :create
open-args) #2#))
(stream stream)))
(defmacro with-temp-file ((stream &rest open-temp-args) &body body)
"Execute BODY within a dynamic extent where STREAM is bound to
a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are
passed verbatim to OPEN-TEMP-FILE."
`(be ,stream (open-temp-file ,@open-temp-args)
(unwind-protect
(progn ,@body)
(close ,stream)
;; body may decide to rename the file so we must ignore the errors
(ignore-errors
(delete-file (pathname ,stream))))))

1
third_party/lisp/sclf/.skip-subtree vendored
View file

@ -1 +0,0 @@
prevent readTree from creating entries for subdirs that don't contain an .nix files

3
third_party/lisp/sclf/OWNERS vendored
View file

@ -1,3 +0,0 @@
inherited: true
owners:
- sterni

6
third_party/lisp/sclf/README vendored
View file

@ -1,6 +0,0 @@
SCLF has originally been written by Walter C. Pelissero and vendored
into depot since it is a dependency of mime4cl. Upstream and depot version
may diverge.
Upstream Website: http://wcp.sdf-eu.org/software/#sclf
Vendored Tarball: http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz

28
third_party/lisp/sclf/default.nix vendored
View file

@ -1,28 +0,0 @@
# Copyright (C) 2021 by the TVL Authors
# SPDX-License-Identifier: LGPL-2.1-or-later
{ depot, pkgs, ... }:
depot.nix.buildLisp.library {
name = "sclf";
deps = [
(depot.nix.buildLisp.bundled "sb-posix")
];
srcs = [
./package.lisp
./sclf.lisp
./sysproc.lisp
./lazy.lisp
./time.lisp
./directory.lisp
./serial.lisp
./mp/sbcl.lisp
];
# TODO(sterni): implement OS interaction for ECL and CCL
brokenOn = [
"ecl"
"ccl"
];
}

404
third_party/lisp/sclf/directory.lisp vendored
View file

@ -1,404 +0,0 @@
;;; directory.lisp --- filesystem directory access
;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
;;; Copyright (C) 2021 by the TVL Authors
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: sclf
#+cmu (ext:file-comment "$Module: directory.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(cl:in-package :sclf)
(defun pathname-as-directory (pathname)
"Converts PATHNAME to directory form and return it."
(setf pathname (pathname pathname))
(if (pathname-name pathname)
(make-pathname :directory (append (or (pathname-directory pathname)
'(:relative))
(list (file-namestring pathname)))
:name nil
:type nil
:defaults pathname)
pathname))
(defun d+ (path &rest rest)
"Concatenate directory pathname parts and return a pathname."
(make-pathname :defaults path
:directory (append (pathname-directory path) rest)))
(defun delete-directory (pathname)
"Remove directory PATHNAME. Return PATHNAME."
#+cmu (multiple-value-bind (done errno)
(unix:unix-rmdir (namestring pathname))
(unless done
(error "Unable to delete directory ~A (errno=~A)"
pathname errno)))
#+sbcl (sb-posix:rmdir pathname)
#+lispworks (lw:delete-directory pathname)
#-(or cmu sbcl)
(error "DELETE-DIRECTORY not implemented for you lisp system.")
pathname)
(defun list-directory (pathname &key truenamep)
"List content of directory PATHNAME. If TRUENAMEP is true don't try
to follow symbolic links."
#-(or sbcl cmu) (declare (ignore truenamep))
(let (#+cmu (lisp::*ignore-wildcards* t))
(directory (make-pathname :defaults (pathname-as-directory pathname)
:name :wild
:type :wild
:version :wild)
#+cmu :truenamep #+cmu truenamep
#+sbcl :resolve-symlinks #+sbcl truenamep)))
(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first)
"Call PROC on all pathnames under ROOT-PATHNAME, both files and
directories. Unless TRUENAMEP is true, this function doesn't try
to lookup the truename of files, as finding the truename may be a
superfluous and noxious activity expecially when you expect
broken symbolic links in your filesystem."
(check-type root-pathname pathname)
(check-type proc (or function symbol))
(check-type test (or function symbol null))
(labels ((ls (dir)
(declare (type pathname dir))
(list-directory dir :truenamep truenamep))
(traverse? (file)
(declare (type pathname file))
(and (not (pathname-name file))
(or truenamep
(not (symbolic-link-p file)))
(or (not test)
(funcall test file))))
(traverse-pre-order (dir)
(declare (type pathname dir))
(loop
for file in (ls dir)
do (funcall proc file)
when (traverse? file)
do (traverse-pre-order file)))
(traverse-post-order (dir)
(declare (type pathname dir))
(loop
for file in (ls dir)
when (traverse? file)
do (traverse-post-order file)
do (funcall proc file))))
(if depth-first
(traverse-post-order root-pathname)
(traverse-pre-order root-pathname))
(values)))
(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body)
"Call TRAVERSE-DIRECTORY-TREE with BODY es procedure."
`(traverse-directory-tree ,root-pathname
#'(lambda (,file)
,@body)
:truenamep ,truenamep
:test ,test
:depth-first ,depth-first))
(defun empty-directory-p (pathname)
(and (directory-p pathname)
(endp (list-directory pathname))))
(defun remove-empty-directories (root)
(do-directory-tree (pathname root :depth-first t)
(when (empty-directory-p pathname)
(delete-directory pathname))))
(defun map-directory-tree (pathname function)
"Apply FUNCTION to every file in a directory tree starting from
PATHNAME. Return the list of results."
(be return-list '()
(do-directory-tree (directory-entry pathname)
(push (funcall function directory-entry) return-list))
(nreverse return-list)))
(defun find-files (root-pathname matcher-function &key truenamep)
"In the directory tree rooted at ROOT-PATHNAME, find files that
when the pathname is applied to MATCHER-FUNCTION will return
true. Return the list of files found. Unless TRUENAMEP is true
this function doesn't try to lookup the truename of
files. Finding the truename may be a superfluous and noxious
activity expecially when you expect broken symbolic links in your
filesystem. (This may not apply to your particular lisp
system.)"
(be files '()
(do-directory-tree (file root-pathname :truenamep truenamep)
(when (funcall matcher-function file)
(push file files)))
(nreverse files)))
(defun delete-directory-tree (pathname)
"Recursively delete PATHNAME and all the directory structure below
it.
WARNING: depending on the way the DIRECTORY function is implemented on
your Lisp system this function may follow Unix symbolic links and thus
delete files outside the PATHNAME hierarchy. Check this before using
this function in your programs."
(if (pathname-name pathname)
(delete-file pathname)
(progn
(dolist (file (list-directory pathname))
(delete-directory-tree file))
(delete-directory pathname))))
(defun make-directory (pathname &optional (mode #o777))
"Create a new directory in the filesystem. Permissions MODE
will be assigned to it. Return PATHNAME."
#+cmu (multiple-value-bind (done errno)
(unix:unix-mkdir (native-namestring pathname) mode)
(unless done
(error "Unable to create directory ~A (errno=~A)." pathname errno)))
#+sbcl (sb-posix:mkdir pathname mode)
#-(or cmu sbcl)
(error "MAKE-DIRECTORY is not implemented for this Lisp system.")
pathname)
;; At least on SBCL/CMUCL + Unix + NFS this function is faster than
;; ENSURE-DIRECTORIES-EXIST, because it doesn't check all the pathname
;; components starting from the root; it proceeds from the leaf and
;; crawls the directory tree upward only if necessary."
(defun ensure-directory (pathname &key verbose (mode #o777))
"Just like ENSURE-DIRECTORIES-EXIST but, in some situations,
it's faster."
(labels ((ensure (path)
(unless (probe-file path)
(be* tail (last (pathname-directory path) 2)
last (cdr tail)
(setf (cdr tail) nil)
(unwind-protect
(ensure path)
(setf (cdr tail) last))
(make-directory path mode)
(when verbose
(format t "Created ~S~%" path))))))
(ensure (make-pathname :defaults pathname
:name nil :type nil
:version nil))))
(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777))
"Create a new directory and return its pathname.
If DEFAULT-PATHNAME is specified and not NIL it's used as
defaults to produce the pathname of the directory. Return the
pathname of the temporary directory."
(loop
for name = (pathname-as-directory (temp-file-name default-pathname))
when (ignore-errors (make-directory name mode))
return name))
(defmacro with-temp-directory ((path &rest make-temp-directory-args) &body body)
"Execute BODY with PATH bound to the pathname of a new unique
temporary directory. On exit of BODY the directory tree starting from
PATH will be automatically removed from the filesystem. Return what
BODY returns. BODY is _not_ executed within the PATH directory; the
working directory is never changed."
`(be ,path (make-temp-directory ,@make-temp-directory-args)
(unwind-protect
(progn ,@body)
(delete-directory-tree ,path))))
(defun current-directory ()
"Return the pathname of the current directory."
(truename (make-pathname :directory '(:relative))))
(defun ensure-home-translations ()
"Ensure that the logical pathname translations for the host \"home\"
are defined."
;; CMUCL already defines a HOME translation of its own and gets
;; angry if we try to redefine it
#-cmu
(be home (user-homedir-pathname)
;; we should discard and replace whatever has been defined in any
;; rc file during compilation
(setf (logical-pathname-translations "home")
(list
(list "**;*.*.*"
(make-pathname :defaults home
:directory (append (pathname-directory home)
'(:wild-inferiors))
:name :wild
:type :wild))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
#+sbcl (sb-ext:parse-native-namestring string host defaults
:start start
:end end
:junk-allowed junk-allowed)
#-sbcl (let (#+cmu(lisp::*ignore-wildcards* t))
(parse-namestring string host defaults
:start start
:end end
:junk-allowed junk-allowed)))
(defun native-namestring (pathname)
#+sbcl (sb-ext:native-namestring pathname)
#-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
(namestring pathname)))
(defun native-file-namestring (pathname)
#+sbcl (sb-ext:native-namestring
(make-pathname :name (pathname-name pathname)
:type (pathname-type pathname)))
#+cmu (be lisp::*ignore-wildcards* t
(file-namestring pathname)))
(defun native-pathname (thing)
#+sbcl (sb-ext:native-pathname thing)
#+cmu (be lisp::*ignore-wildcards* t
(pathname thing)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bits-set-p (x bits)
(= (logand x bits)
bits))
(defun directory-p (pathname)
"Return true if PATHNAME names a directory on the filesystem."
#-clisp (awhen (unix-stat (native-namestring pathname))
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-ifdir
#+cmu unix:s-ifdir))
#+clisp (ext:probe-directory (pathname-as-directory pathname)))
(defun regular-file-p (pathname)
"Return true if PATHNAME names a regular file on the filesystem."
#-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file")
(awhen (unix-stat (native-namestring pathname))
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-ifreg
#+cmu unix:s-ifreg)))
(defun file-readable-p (pathname)
#+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok)
#+cmu (unix:unix-access (native-namestring pathname) unix:r_ok)
#-(or sbcl cmu) (error "don't know how to check whether a file might be readable"))
(defun file-writable-p (pathname)
#+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:w_ok)
#+cmu (unix:unix-access (native-namestring pathname) unix:w_ok)
#-(or sbcl cmu) (error "don't know how to check whether a file might be writable"))
(defun file-executable-p (pathname)
#+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:x_ok)
#+cmu (unix:unix-access (native-namestring pathname) unix:x_ok)
#-(or sbcl cmu) (error "don't know how to check whether a file might be executable"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct (unix-file-stat (:conc-name stat-))
device
inode
links
atime
mtime
ctime
size
blksize
blocks
uid
gid
mode)
(defun unix-stat (pathname)
;; this could be different depending on the unix systems
(multiple-value-bind (ok? device inode mode links uid gid rdev
size atime mtime ctime
blksize blocks)
(#+cmu unix:unix-lstat
#+sbcl sb-unix:unix-lstat
(if (stringp pathname)
pathname
(native-namestring pathname)))
(declare (ignore rdev))
(when ok?
(make-unix-file-stat :device device
:inode inode
:links links
:atime atime
:mtime mtime
:ctime ctime
:size size
:blksize blksize
:blocks blocks
:uid uid
:gid gid
:mode mode))))
(defun stat-modification-time (stat)
"Return the modification time of the STAT structure as Lisp
Universal Time, which is not the same as the Unix time."
(unix->universal-time (stat-mtime stat)))
(defun stat-creation-time (stat)
"Return the creation time of the STAT structure as Lisp
Universal Time, which is not the same as the Unix time."
(unix->universal-time (stat-ctime stat)))
(defun file-modification-time (file)
"Return the modification time of FILE as Lisp Universal Time, which
is not the same as the Unix time."
(awhen (unix-stat file)
(stat-modification-time it)))
(defun file-creation-time (file)
"Return the creation time of FILE as Lisp Universal Time, which
is not the same as the Unix time."
(awhen (unix-stat file)
(stat-creation-time it)))
(defun read-symbolic-link (symlink)
"Return the pathname the SYMLINK points to. That is, it's
contents."
#+sbcl (sb-posix:readlink (native-namestring symlink))
#+cmu (unix:unix-readlink (native-namestring symlink)))
;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix
;; allows to get to know the file size without being able to open a
;; file; just ask politely.
(defun file-size (pathname)
(stat-size (unix-stat pathname)))
(defun symbolic-link-p (pathname)
#-(or sbcl cmu) (error "don't know hot to test for symbolic links.")
(aand (unix-stat pathname)
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-iflnk
#+cmu unix:s-iflnk)))
(defun broken-link-p (pathname)
(when (symbolic-link-p pathname)
#+cmu (not (ignore-errors (truename pathname)))
;; On a broken symlink SBCL returns the link path without resolving
;; the link itself. De gustibus non est disputandum.
#+sbcl (equalp pathname (probe-file pathname))))
(defun move-file (old new)
"Just like RENAME-FILE, but doesn't carry on to NEW file the type of
OLD file, if NEW doesn't specify one. It does what most people would
expect from a rename function, which RENAME-FILE doesn't do.
So (MOVE-FILE \"foo.bar\" \"foo\") does rename foo.bar to foo, losing
the \"bar\" type; RENAME-FILE wouldn't allow you that."
#+sbcl (sb-posix:rename (native-namestring old) (native-namestring new))
#+cmu (unix:unix-rename (native-namestring old) (native-namestring new)))

134
third_party/lisp/sclf/lazy.lisp vendored
View file

@ -1,134 +0,0 @@
;;; lazy.lisp --- lazy primitives
;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: sclf
#+cmu (ext:file-comment "$Module: lazy.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Lazy primitives
;;;
(in-package :sclf)
(defstruct promise
procedure
value)
(defmacro lazy (form)
`(make-promise :procedure #'(lambda () ,form)))
(defun forced-p (promise)
(null (promise-procedure promise)))
(defun force (promise)
(if (forced-p promise)
(promise-value promise)
(prog1 (setf (promise-value promise)
(funcall (promise-procedure promise)))
(setf (promise-procedure promise) nil))))
(defmacro deflazy (name value &optional documentation)
`(defparameter ,name (lazy ,value)
,@(when documentation
(list documentation))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass lazy-metaclass (standard-class)
()
(:documentation "Metaclass for object having lazy slots. Lazy slots
should be specified with the :LAZY keyword which must be a function of
one argument. If required this function will be called once to get
the value to memoize in the slot. Lazy slots can also be set/read as
any other."))
(defmethod validate-superclass ((class lazy-metaclass) (super standard-class))
"Lazy classes may inherit from ordinary classes."
(declare (ignore class super))
t)
(defmethod validate-superclass ((class standard-class) (super lazy-metaclass))
"Ordinary classes may inherit from lazy classes."
(declare (ignore class super))
t)
(defclass lazy-slot-mixin ()
((lazy-function :initarg :lazy
:reader lazy-slot-function
:initform nil))
(:documentation
"Slot for LAZY-METACLASS classes. Lazy slots must be declared with
the argument :LAZY which must be a function accepting the object
instance as argument."))
(defclass lazy-direct-slot-definition (lazy-slot-mixin standard-direct-slot-definition)
())
(defclass lazy-effective-slot-definition (lazy-slot-mixin standard-effective-slot-definition)
())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod direct-slot-definition-class ((class lazy-metaclass) &rest initargs)
(if (getf initargs :lazy nil)
(find-class 'lazy-direct-slot-definition)
(call-next-method)))
(defmethod effective-slot-definition-class ((class lazy-metaclass) &rest initargs)
(if (getf initargs :lazy nil)
(find-class 'lazy-effective-slot-definition)
(call-next-method)))
(defmethod compute-effective-slot-definition-initargs ((class lazy-metaclass) direct-slots)
(let ((ds (car direct-slots)))
(if (typep ds 'lazy-direct-slot-definition)
(let ((form (lazy-slot-function ds))
(args (call-next-method)))
(when (or (getf args :initarg)
(getf args :initform))
(error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds))
(list* :lazy
(cond ((and (listp form)
(eq 'lambda (car form)))
(compile nil form))
((symbolp form)
form)
(t (compile nil `(lambda (self)
(declare (ignorable self))
,form))))
args))
(call-next-method))))
(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin))
(declare (ignore class))
;; If the slot is unbound, call the lazy function passing the
;; instance and memoize the value in the slot.
(unless (slot-boundp-using-class class instance slot)
(setf (slot-value-using-class class instance slot)
(funcall (lazy-slot-function slot) instance)))
(call-next-method))
(defun reset-lazy-slots (object)
"Unbind all the lazy slots in OBJECT so that they will be
re-evaluated next time their value is requested again."
(be* class (class-of object)
(dolist (slot (class-slots class))
(when (typep slot 'lazy-effective-slot-definition)
(slot-makunbound object (slot-definition-name slot))))))

6
third_party/lisp/sclf/mp/README vendored
View file

@ -1,6 +0,0 @@
This directory contains an uniforming layer for multiprocessing in the
style supported by Allegro Common Lisp and CMUCL. Almost nothing of
this has been written by me. It's mostly the work of Gilbert Baumann
(unk6@rz.uni-karlsruhe.de) and I've shamelessly lifted it from McCLIM.
The copyright disclaimer in this code is compatible with the one of
SCLF, so I believe there should be no legal issues.

115
third_party/lisp/sclf/mp/cmu.lisp vendored
View file

@ -1,115 +0,0 @@
;;;
;;; Code freely lifted from various places with compatible license
;;; terms. Most of this code is copyright Gilbert Baumann
;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter
;;; C. Pelissero <walter@pelissero.de>.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :sclf)
(defun make-lock (&optional name)
(mp:make-lock name))
(defun make-recursive-lock (&optional name)
(mp:make-lock name :kind :recursive))
(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms)
`(mp:with-lock-held (,lock ,(or whostate "Lock Wait")
:wait wait
,@(when timeout (list :timeout timeout)))
,@forms))
(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms)
`(mp:with-lock-held (,lock
,@(when wait (list :wait wait))
,@(when timeout (list :timeout timeout)))
,@forms))
(defstruct condition-variable
(lock (make-lock "condition variable"))
(value nil)
(process-queue nil))
(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp
#+i486 (kernel:%instance-set-conditional
lock 2 mp:*current-process* nil)
#-i486 (when (eq (lock-process lock) mp:*current-process*)
(setf (lock-process lock) nil)))
(defun condition-wait (cv lock &optional timeout)
(declare (ignore timeout)) ;For now
(loop
(let ((cv-lock (condition-variable-lock cv)))
(with-lock-held (cv-lock)
(when (condition-variable-value cv)
(setf (condition-variable-value cv) nil)
(return-from condition-wait t))
(setf (condition-variable-process-queue cv)
(nconc (condition-variable-process-queue cv)
(list mp:*current-process*)))
(%release-lock lock))
(mp:process-add-arrest-reason mp:*current-process* cv)
(let ((cv-val nil))
(with-lock-held (cv-lock)
(setq cv-val (condition-variable-value cv))
(when cv-val
(setf (condition-variable-value cv) nil)))
(when cv-val
(mp::lock-wait lock "waiting for condition variable lock")
(return-from condition-wait t))))))
(defun condition-notify (cv)
(with-lock-held ((condition-variable-lock cv))
(let ((proc (pop (condition-variable-process-queue cv))))
;; The waiting process may have released the CV lock but not
;; suspended itself yet
(when proc
(loop
for activep = (mp:process-active-p proc)
while activep
do (mp:process-yield))
(setf (condition-variable-value cv) t)
(mp:process-revoke-arrest-reason proc cv))))
;; Give the other process a chance
(mp:process-yield))
(defun process-execute (process function)
(mp:process-preset process function)
;; For some obscure reason process-preset doesn't make the process
;; runnable. I'm sure it's me who didn't understand how
;; multiprocessing works under CMUCL, despite the vast documentation
;; available.
(mp:enable-process process)
(mp:process-add-run-reason process :enable))
(defun destroy-process (process)
;; silnetly ignore a process that is trying to destroy itself
(unless (eq (mp:current-process)
process)
(mp:destroy-process process)))
(defun restart-process (process)
(mp:restart-process process)
(mp:enable-process process)
(mp:process-add-run-reason process :enable))
(defun process-alive-p (process)
(mp:process-alive-p process))
(defun process-join (process)
(error "PROCESS-JOIN not support under CMUCL."))

235
third_party/lisp/sclf/mp/sbcl.lisp vendored
View file

@ -1,235 +0,0 @@
;;;
;;; Code freely lifted from various places with compatible license
;;; terms. Most of this code is copyright Daniel Barlow
;;; <dan@metacircles.com> or Gilbert Baumann
;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter
;;; C. Pelissero <walter@pelissero.de>.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :sclf)
(defstruct (process
(:constructor %make-process)
(:predicate processp))
name
state
whostate
function
thread)
(defvar *current-process*
(%make-process
:name "initial process" :function nil
:thread
#+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))
sb-thread:*current-thread*
#-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))
(sb-thread:current-thread-id)))
(defvar *all-processes* (list *current-process*))
(defvar *all-processes-lock*
(sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*"))
;; we implement disable-process by making the disablee attempt to lock
;; *permanent-queue*, which is already locked because we locked it
;; here. enable-process just interrupts the lock attempt.
(defmacro get-mutex (mutex &optional (wait t))
`(
#+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
sb-thread:grab-mutex
#-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
sb-thread:get-mutex
,mutex :waitp ,wait))
(defvar *permanent-queue*
(sb-thread:make-mutex :name "Lock for disabled threads"))
(unless (sb-thread:mutex-owner *permanent-queue*)
(get-mutex *permanent-queue* nil))
(defun make-process (function &key name)
(let ((p (%make-process :name name
:function function)))
(sb-thread:with-mutex (*all-processes-lock*)
(pushnew p *all-processes*))
(restart-process p)))
(defun process-kill-thread (process)
(let ((thread (process-thread process)))
(when (and thread
(sb-thread:thread-alive-p thread))
(assert (not (eq thread sb-thread:*current-thread*)))
(sb-thread:terminate-thread thread)
;; Wait until all the clean-up forms are done.
(sb-thread:join-thread thread :default nil))
(setf (process-thread process) nil)))
(defun process-join (process)
(sb-thread:join-thread (process-thread process)))
(defun restart-process (p)
(labels ((boing ()
(let ((*current-process* p)
(function (process-function p)))
(when function
(funcall function)))))
(process-kill-thread p)
(when (setf (process-thread p)
(sb-thread:make-thread #'boing :name (process-name p)))
p)))
(defun destroy-process (process)
(sb-thread:with-mutex (*all-processes-lock*)
(setf *all-processes* (delete process *all-processes*)))
(process-kill-thread process))
(defun current-process ()
*current-process*)
(defun all-processes ()
;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value
;; while that delete is executing, we could end up with nonsense.
;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS).
(sb-thread:with-mutex (*all-processes-lock*)
*all-processes*))
(defun process-yield ()
(sb-thread:thread-yield))
(defun process-wait (reason predicate)
(let ((old-state (process-whostate *current-process*)))
(unwind-protect
(progn
(setf old-state (process-whostate *current-process*)
(process-whostate *current-process*) reason)
(until (funcall predicate)
(process-yield)))
(setf (process-whostate *current-process*) old-state))))
(defun process-wait-with-timeout (reason timeout predicate)
(let ((old-state (process-whostate *current-process*))
(end-time (+ (get-universal-time) timeout)))
(unwind-protect
(progn
(setf old-state (process-whostate *current-process*)
(process-whostate *current-process*) reason)
(loop
for result = (funcall predicate)
until (or result
(> (get-universal-time) end-time))
do (process-yield)
finally (return result)))
(setf (process-whostate *current-process*) old-state))))
(defun process-interrupt (process function)
(sb-thread:interrupt-thread (process-thread process) function))
(defun disable-process (process)
(sb-thread:interrupt-thread
(process-thread process)
(lambda ()
(catch 'interrupted-wait (get-mutex *permanent-queue*)))))
(defun enable-process (process)
(sb-thread:interrupt-thread
(process-thread process) (lambda () (throw 'interrupted-wait nil))))
(defmacro without-scheduling (&body body)
(declare (ignore body))
(error "WITHOUT-SCHEDULING is not supported on this platform."))
(defparameter *atomic-lock*
(sb-thread:make-mutex :name "atomic incf/decf"))
(defmacro atomic-incf (place)
`(sb-thread:with-mutex (*atomic-lock*)
(incf ,place)))
(defmacro atomic-decf (place)
`(sb-thread:with-mutex (*atomic-lock*)
(decf ,place)))
;;; 32.3 Locks
(defun make-lock (&optional name)
(sb-thread:make-mutex :name name))
(defmacro with-lock-held ((place &key state (wait t) timeout) &body body)
(declare (ignore timeout))
(let ((old-state (gensym "OLD-STATE")))
`(sb-thread:with-mutex (,place :wait-p ,wait)
(let (,old-state)
(unwind-protect
(progn
(when ,state
(setf ,old-state (process-state *current-process*))
(setf (process-state *current-process*) ,state))
,@body)
(setf (process-state *current-process*) ,old-state))))))
(defun make-recursive-lock (&optional name)
(sb-thread:make-mutex :name name))
(defmacro with-recursive-lock-held ((place &optional state (wait t) timeout) &body body)
(declare (ignore wait timeout))
(let ((old-state (gensym "OLD-STATE")))
`(sb-thread:with-recursive-lock (,place)
(let (,old-state)
(unwind-protect
(progn
(when ,state
(setf ,old-state (process-state *current-process*))
(setf (process-state *current-process*) ,state))
,@body)
(setf (process-state *current-process*) ,old-state))))))
(defun make-condition-variable () (sb-thread:make-waitqueue))
(defun condition-wait (cv lock &optional timeout)
(if timeout
(handler-case
(sb-ext:with-timeout timeout
(sb-thread:condition-wait cv lock)
t)
(sb-ext:timeout (c)
(declare (ignore c))
nil))
(progn (sb-thread:condition-wait cv lock) t)))
(defun condition-notify (cv)
(sb-thread:condition-notify cv))
(defvar *process-plists* (make-hash-table)
"Hash table mapping processes to a property list. This is used by
PROCESS-PLIST.")
(defun process-property-list (process)
(gethash process *process-plists*))
(defun (setf process-property-list) (value process)
(setf (gethash process *process-plists*) value))
(defun process-execute (process function)
(setf (process-function process) function)
(restart-process process))
(defun process-alive-p (process)
(sb-thread:thread-alive-p (process-thread process)))

258
third_party/lisp/sclf/package.lisp vendored
View file

@ -1,258 +0,0 @@
;;; package.lisp --- packages description
;;; Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
;;; Copyright (C) 2021 by the TVL Authors
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: sclf
#+cmu (ext:file-comment "$Module: package.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :cl-user)
(defpackage :sclf
(:use :common-lisp
;; we need the MOP for lazy.lisp and serial.lisp
#+cmu :pcl
#+sbcl :sb-mop)
;; Don't know why but compute-effective-slot-definition-initargs is
;; internal in both CMUCL and SBCL
(:import-from #+cmu"PCL" #+sbcl"SB-PCL"
#-(or cmu sbcl) "CLOS"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS")
#+cmu (:import-from :mp
#:make-process
#:current-process
#:all-processes
#:processp
#:process-name
#:process-state
#:process-whostate
#:process-wait
#:process-wait-with-timeout
#:process-yield
#:process-interrupt
#:disable-process
#:enable-process
#:without-scheduling
#:atomic-incf
#:atomic-decf
#:process-property-list)
(:export #:be #:be*
#:defconst
#:with-gensyms
#:d+
#:s+
#:f++
#:list->string
#:string-starts-with #:string-ends-with
#:aif #:awhen #:acond #:aand #:acase #:it
#:+whitespace+
#:string-trim-whitespace
#:string-right-trim-whitespace
#:string-left-trim-whitespace
#:whitespace-p #:seq-whitespace-p
#:not-empty
#:position-any
#:+month-names+
#:find-any
#:split-at
#:split-string-at-char
#:week-day->string
#:month->string
#:month-string->number
#:add-months #:add-days
#:read-whole-stream
#:read-file #:write-file #:read-lines
#:read-from-file #:write-to-file
#:string-concat
#:gcase
#:string-truncate
#:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots
#:copy-stream #:copy-file
#:symlink-file
#:keywordify
#:until
#:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year
#:beginning-of-week #:end-of-week
#:next-week-day #:next-monday #:full-weeks-in-span
#:beginning-of-first-week #:end-of-last-week
#:beginning-of-month #:end-of-month
#:locate-system-program
#:*tmp-file-defaults*
#:temp-file-name
#:open-temp-file
#:with-temp-file
#:file-size
#:getenv
#:with-system-environment
#:time-string #:iso-time-string #:parse-iso-time-string
#:soundex
#:string-soundex=
#:lru-cache
#:getcache #:cached
#:print-time-span
#:double-linked-list #:limited-list #:sorted-list
#:insert #:size
#:heap #:heap-add #:heap-pop #:heap-empty-p
#:double-linked-element #:make-double-linked-element #:double-linked-element-p
#:dle-previous #:dle-next #:dle-value
#:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle*
#:sl-map #:do-dll #:do-dll*
#:dll-find #:dll-find-cursor
#:push-first #:push-last #:dll-remove
#:pop-first #:pop-last
#:leap-year-p #:last-day-of-month
#:getuid #:setuid #:with-euid
#:get-logname #:get-user-name #:get-user-home #:find-uid
#:super-user-p
#:pathname-as-directory #:pathname-as-file
#:alist->plist #:plist->alist
#:byte-vector->string
#:string->byte-vector
#:outdated-p
#:with-hidden-temp-file
#:let-places #:let-slots
#:*decimal-point*
#:*thousands-comma*
#:format-amount #:parse-amount
#:with-package
#:make-directory #:ensure-directory
#:make-temp-directory
#:with-temp-directory
#:delete-directory
#:delete-directory-tree
#:do-directory-tree
#:traverse-directory-tree
#:empty-directory-p
#:remove-empty-directories
#:map-directory-tree
#:find-files
#:directory-p
#:regular-file-p
#:file-readable-p
#:file-writable-p
#:file-executable-p
#:current-directory
#:ensure-home-translations
#:list-directory
#:string-escape
#:string-substitute
#:bytes-simple-string
#:make-lock-files
#:with-lock-files
#:getpid
#:on-error
#:floor-to
#:round-to
#:ceiling-to
#:insert-in-order
#:forget-documentation
#:load-compiled
#:swap
#:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p
#:unix-stat #:unix-file-stat
#:stat-device
#:stat-inode
#:stat-links
#:stat-atime
#:stat-mtime
#:stat-ctime
#:stat-birthtime
#:stat-size
#:stat-blksize
#:stat-blocks
#:stat-uid
#:stat-gid
#:stat-mode
#:save-file-excursion
#:stat-modification-time
#:stat-creation-time
#:file-modification-time
#:file-creation-time
#:show
#:memoize-function
#:memoized
#:defun-memoized
#:parse-native-namestring
#:native-file-namestring
#:native-namestring
#:native-pathname
#:read-symbolic-link
#:symbolic-link-p
#:broken-link-p
#:circular-list
#:last-member
#:glob->regex
#:universal->unix-time #:unix->universal-time
#:get-unix-time
#:move-file
;; sysproc.lisp
#:*run-verbose*
#:run-pipe
#:run-program
#:run-shell-command
#:run-async-shell-command
#:exit-code
#:with-open-pipe
#:*bourne-shell*
#:sysproc-kill
#:sysproc-input
#:sysproc-output
#:sysproc-alive-p
#:sysproc-pid
#:sysproc-p
#:sysproc-wait
#:sysproc-exit-code
#:sysproc-set-signal-callback
;; MP
#:make-process
#:destroy-process
#:current-process
#:all-processes
#:processp
#:process-name
#:process-state
#:process-whostate
#:process-wait
#:process-wait-with-timeout
#:process-yield
#:process-interrupt
#:disable-process
#:enable-process
#:restart-process
#:without-scheduling
#:atomic-incf
#:atomic-decf
#:process-property-list
#:process-alive-p
#:process-join
;;
#:make-lock
#:with-lock-held
#:make-recursive-lock
#:with-recursive-lock-held
;;
#:make-condition-variable
#:condition-wait
#:condition-notify
#:process-property-list
#:process-execute
;; mop.lisp
#:printable-object-mixin
))

58
third_party/lisp/sclf/sclf.asd vendored
View file

@ -1,58 +0,0 @@
;;; sclf.asd --- system definition
;;; Copyright (C) 2005, 2006, 2008, 2009 by Walter C. Pelissero
;;; Copyright (C) 2021 by the TVL Authors
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: SCLF
#+cmu (ext:file-comment "$Module: sclf.asd, Time-stamp: <2013-06-17 15:32:29 wcp> $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :cl-user)
(defpackage :sclf-system
(:use :common-lisp :asdf #+asdfa :asdfa))
(in-package :sclf-system)
(defsystem sclf
:name "SCLF"
:author "Walter C. Pelissero <walter@pelissero.de>"
:maintainer "Walter C. Pelissero <walter@pelissero.de>"
;; :version "0.0"
:description "Stray Common Lisp Functions"
:long-description
"A collection of Common Lisp functions for the most disparate
uses, too small to fit anywhere else."
:licence "LGPL"
:depends-on (#+sbcl :sb-posix)
:components
((:doc-file "README")
(:file "package")
(:file "sclf" :depends-on ("package"))
(:file "sysproc" :depends-on ("package" "sclf"))
(:file "lazy" :depends-on ("package" "sclf"))
(:file "time" :depends-on ("package" "sclf"))
(:file "directory" :depends-on ("package" "sclf" "time"))
(:file "serial" :depends-on ("package" "sclf"))
(:module "mp"
:depends-on ("package" "sclf")
:components
((:doc-file "README")
(:file #.(first
(list #+cmu "cmu"
#+sbcl "sbcl"
"unknown")))))))

1717
third_party/lisp/sclf/sclf.lisp vendored
View file

File diff suppressed because it is too large Load diff

62
third_party/lisp/sclf/serial.lisp vendored
View file

@ -1,62 +0,0 @@
;;; serial.lisp --- serialisation of CLOS objects
;;; Copyright (C) 2009 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: sclf
#+cmu (ext:file-comment "$Module: serial.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :sclf)
(defclass printable-object-mixin () ())
(defmacro reconstruct-object (class &rest args)
`(apply #'make-instance ',class ',args))
(defun print-readable-instance (object &optional stream)
(unless stream
(setf stream *standard-output*))
(be class (class-of object)
(pprint-logical-block (stream (copy-list (class-slots class)) :prefix "#.(" :suffix ")")
(flet ((spc ()
(write-char #\space stream)))
(write 'reconstruct-object :stream stream)
(spc)
(write (class-name class) :stream stream :escape t :readably t :pretty t)
(pprint-exit-if-list-exhausted)
(spc)
(loop
(be* slot (pprint-pop)
slot-name (slot-definition-name slot)
initarg (car (slot-definition-initargs slot))
(when (and initarg
(slot-boundp object slot-name))
(write initarg :stream stream)
(spc)
(when *print-pretty*
(pprint-newline :miser stream))
(write (slot-value object slot-name)
:stream stream)
(pprint-exit-if-list-exhausted)
(if *print-pretty*
(pprint-newline :linear stream)
(spc)))))))))
(defmethod print-object ((object printable-object-mixin) stream)
(if *print-readably*
(print-readable-instance object stream)
(call-next-method)))

295
third_party/lisp/sclf/sysproc.lisp vendored
View file

@ -1,295 +0,0 @@
;;; sysproc.lisp --- system processes
;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: sclf
#+cmu (ext:file-comment "$Module: sysproc.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :sclf)
(defvar *bourne-shell* "/bin/sh")
(defvar *run-verbose* nil
"If true system commands are displayed before execution and standard
error is not discarded.")
;;
;; SIGINFO is missing in both CMUCL and SBCL
;;
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant unix::siginfo 29)
(defvar siginfo (unix::make-unix-signal :siginfo unix::siginfo "Information"))
(export '(unix::siginfo) "UNIX")
(pushnew siginfo unix::*unix-signals*))
#+sbcl (in-package :sb-posix)
#+sbcl
(eval-when (:execute :compile-toplevel :load-toplevel)
(unless (find-symbol "SIGINFO" :sb-posix)
(sb-ext:with-unlocked-packages (:sb-posix)
(defvar siginfo 29)
(export '(SIGINFO)))))
#+sbcl (in-package :sclf)
(defun signal-number (signal-name)
(ecase signal-name
((:abrt :abort)
#+cmu unix:sigabrt
#+sbcl sb-posix:sigabrt)
((:alrm :alarm)
#+cmu unix:sigalrm
#+sbcl sb-posix:sigalrm)
((:bus :bus-error)
#+cmu unix:sigbus
#+sbcl sb-posix:sigbus)
((:chld :child)
#+cmu unix:sigchld
#+sbcl sb-posix:sigchld)
((:cont :continue)
#+cmu unix:sigcont
#+sbcl sb-posix:sigcont)
#+freebsd((:emt :emulate-instruction)
#+cmu unix:sigemt
#+sbcl sb-posix:sigemt)
((:fpe :floating-point-exception)
#+cmu unix:sigfpe
#+sbcl sb-posix:sigfpe)
((:hup :hangup)
#+cmu unix:sighup
#+sbcl sb-posix:sighup)
((:ill :illegal :illegal-instruction)
#+cmu unix:sigill
#+sbcl sb-posix:sigill)
((:int :interrupt)
#+cmu unix:sigint
#+sbcl sb-posix:sigint)
((:io :input-output)
#+cmu unix:sigio
#+sbcl sb-posix:sigio)
(:kill
#+cmu unix:sigkill
#+sbcl sb-posix:sigkill)
((:pipe :broke-pipe)
#+cmu unix:sigpipe
#+sbcl sb-posix:sigpipe)
((:prof :profiler)
#+cmu unix:sigprof
#+sbcl sb-posix:sigprof)
(:quit
#+cmu unix:sigquit
#+sbcl sb-posix:sigquit)
((:segv :segmentation-violation)
#+cmu unix:sigsegv
#+sbcl sb-posix:sigsegv)
(:stop
#+cmu unix:sigstop
#+sbcl sb-posix:sigstop)
((:sys :system-call)
#+cmu unix:sigsys
#+sbcl sb-posix:sigsys)
((:term :terminate)
#+cmu unix:sigterm
#+sbcl sb-posix:sigterm)
((:trap)
#+cmu unix:sigtrap
#+sbcl sb-posix:sigtrap)
((:tstp :terminal-stop)
#+cmu unix:sigtstp
#+sbcl sb-posix:sigtstp)
((:ttin :tty-input)
#+cmu unix:sigttin
#+sbcl sb-posix:sigttin)
((:ttou :tty-output)
#+cmu unix:sigttou
#+sbcl sb-posix:sigttou)
((:urg :urgent)
#+cmu unix:sigurg
#+sbcl sb-posix:sigurg)
((:usr1 :user1)
#+cmu unix:sigusr1
#+sbcl sb-posix:sigusr1)
((:usr2 :user2)
#+cmu unix:sigusr2
#+sbcl sb-posix:sigusr2)
((:vtalrm :virtual-timer-alarm)
#+cmu unix:sigvtalrm
#+sbcl sb-posix:sigvtalrm)
((:winch :window-change :window-size-change)
#+cmu unix:sigwinch
#+sbcl sb-posix:sigwinch)
((:xcpu :exceeded-cpu)
#+cmu unix:sigxcpu
#+sbcl sb-posix:sigxcpu)
((:xfsz :exceeded-file-size)
#+cmu unix:sigxfsz
#+sbcl sb-posix:sigxfsz)
;; oddly this is not defined by neither CMUCL nor SBCL
(:info 29)))
(defun sysproc-kill (process signal)
(when (keywordp signal)
(setf signal (signal-number signal)))
#+cmu (ext:process-kill process signal)
#+sbcl (sb-ext:process-kill process signal)
#-(or sbcl cmu) (error "Don't know how to kill a process"))
(defun sysproc-exit-code (process)
#+cmu (ext:process-exit-code process)
#+sbcl (sb-ext:process-exit-code process)
#-(or sbcl cmu) (error "Don't know how to get a process exit code"))
(defun sysproc-wait (process)
#+cmu (ext:process-wait process)
#+sbcl (sb-ext:process-wait process)
#-(or sbcl cmu) (error "Don't know how to wait a process"))
(defun sysproc-input (process)
#+cmu (ext:process-input process)
#+sbcl (sb-ext:process-input process)
#-(or sbcl cmu) (error "Don't know how to get the process input"))
(defun sysproc-output (process)
#+cmu (ext:process-output process)
#+sbcl (sb-ext:process-output process)
#-(or sbcl cmu) (error "Don't know how to get the process output"))
(defun sysproc-alive-p (process)
#+cmu (ext:process-alive-p process)
#+sbcl (sb-ext:process-alive-p process)
#-(or sbcl cmu) (error "Don't know how to test wether a process might be running"))
(defun sysproc-pid (process)
#+cmu (ext:process-pid process)
#+sbcl (sb-ext:process-pid process)
#-(or sbcl cmu) (error "Don't know how to get the id of a process"))
(defun sysproc-p (thing)
#+sbcl (sb-ext:process-p thing)
#+cmu (ext:process-p thing)
#-(or sbcl cmu) (error "Don't know how to figure out whether something is a system process"))
(defun run-program (program arguments &key (wait t) pty input output error)
"Run PROGRAM with ARGUMENTS (a list) and return a process object."
;; convert arguments to strings
(setf arguments
(mapcar #'(lambda (item)
(typecase item
(string item)
(pathname (native-namestring item))
(t (format nil "~A" item))))
arguments))
(when *run-verbose*
(unless error
(setf error t))
(format t "~&; run-pipe ~A~{ ~S~}~%" program arguments))
#+cmu (ext:run-program program arguments
:wait wait
:pty pty
:input input
:output output
:error (or error *run-verbose*))
#+sbcl (sb-ext:run-program program arguments
:search t
:wait wait
:pty pty
:input input
:output output
:error (or error *run-verbose*))
#-(or sbcl cmu)
(error "Unsupported Lisp system."))
(defun run-pipe (direction program arguments &key error)
"Run PROGRAM with a list of ARGUMENTS and according to DIRECTION
return the input and output streams and process object of that
process."
(be process (run-program program arguments
:wait nil
:pty nil
:input (when (member direction '(:output :input-output :io))
:stream)
:output (when (member direction '(:input :input-output :io))
:stream)
:error error)
(values (sysproc-output process)
(sysproc-input process)
process))
#-(or sbcl cmu)
(error "Unsupported Lisp system."))
(defun exit-code (process)
(sysproc-wait process)
(sysproc-exit-code process))
(defun run-shell-command (fmt &rest args)
"Run a Bourne Shell command. Return the exit status of the command."
(run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))))
(defun run-async-shell-command (fmt &rest args)
"Run a Bourne Shell command asynchronously. Return a process
object if provided by your Lisp implementation."
(run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))
:wait nil))
(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms)
"Run BODY with IN and OUT bound respectively to an input and an
output stream connected to a system process created by running PROGRAM
with ARGUMENTS. If IN or OUT are NIL, then don't create that stream."
(with-gensyms (prg args)
`(be* ,prg ,program
,args ,arguments
,process (run-program ,prg ,args
:output ,(case in
((t nil) in)
(t :stream))
:input ,(case out
((t nil) out)
(t :stream))
:wait nil
:pty ,pty
,@(when error `(:error ,error)))
(if ,process
(let (,@(case in
((t nil))
(t `((,in (sysproc-output ,process)))))
,@(case out
((t nil))
(t `((,out (sysproc-input ,process))))))
(unwind-protect
(progn
,@forms)
,@(case in
((t nil))
(t `((close ,in))))
,@(case out
((t nil))
(t `((close ,out))))
(when (sysproc-alive-p ,process)
(sysproc-kill ,process :term))))
(error "unable to run ~A~{ ~A~}." ,prg ,args)))))
(defun sysproc-set-signal-callback (signal handler)
"Arrange HANDLER function to be called when receiving the system
signal SIGNAL."
(when (keywordp signal)
(setf signal (signal-number signal)))
#+cmu (system:enable-interrupt signal handler)
#+sbcl (sb-sys:enable-interrupt signal handler)
#-(or cmu sbcl) (error "Don't know how to set a system signal callback."))

311
third_party/lisp/sclf/time.lisp vendored
View file

@ -1,311 +0,0 @@
;;; time.lisp --- time primitives
;;; Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: sclf
#+cmu (ext:file-comment "$Module: time.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :sclf)
(defun year (epoch &optional time-zone)
"Return the year of EPOCH."
(sixth (multiple-value-list (decode-universal-time epoch time-zone))))
(defun month (epoch &optional time-zone)
"Return the month of EPOCH."
(fifth (multiple-value-list (decode-universal-time epoch time-zone))))
(defun day (epoch &optional time-zone)
"Return the day of EPOCH."
(fourth (multiple-value-list (decode-universal-time epoch time-zone))))
(defun week-day (epoch &optional time-zone)
"Return the day of the week of EPOCH."
(seventh (multiple-value-list (decode-universal-time epoch time-zone))))
(defun hour (epoch &optional time-zone)
"Return the hour of EPOCH."
(third (multiple-value-list (decode-universal-time epoch time-zone))))
(defun minute (epoch &optional time-zone)
"Return the minute of EPOCH."
(second (multiple-value-list (decode-universal-time epoch time-zone))))
(defun leap-year-p (year)
"Return true if YEAR is a leap year."
(and (zerop (mod year 4))
(or (not (zerop (mod year 100)))
(zerop (mod year 400)))))
(defun last-day-of-month (month year)
"Return the last day of the month as integer."
(be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month))
(if (and (= last 28)
(leap-year-p year))
(1+ last)
last)))
(defun add-months (months epoch &optional time-zone)
"Add MONTHS to EPOCH, which is a universal time. MONTHS can be
negative."
(multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone)
(multiple-value-bind (y m) (floor (+ month months -1) 12)
(let ((new-month (1+ m))
(new-year (+ year y)))
(encode-universal-time ss mm hh
(min day (last-day-of-month new-month (year epoch)))
new-month
new-year
time-zone)))))
(defun add-days (days epoch)
"Add DAYS to EPOCH, which is an universal time. DAYS can be
negative."
(+ (* 60 60 24 days) epoch))
;; The following two functions are based on Thomas Russ <tar@isi.edu>
;; code which didn't carry any copyright notice, so I assume it was in
;; the public domain.
(defun iso-time-string (time &key time-zone with-timezone-p basic)
"Return an ISO 8601 string representing TIME. The time zone is
included if WITH-TIMEZONE-P is true."
(flet ((format-timezone (zone)
(if (zerop zone)
"Z"
(multiple-value-bind (h m) (truncate (abs zone) 1.0)
;; Sign of time zone is reversed in ISO 8601 relative
;; to Common Lisp convention!
(format nil "~:[+~;-~]~2,'0D:~2,'0D"
(> zone 0) h (round m))))))
(multiple-value-bind (second minute hour day month year dow dst zone)
(decode-universal-time time time-zone)
(declare (ignore dow dst))
(if basic
(format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]"
year month day hour minute second
with-timezone-p (format-timezone zone))
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
year month day hour minute second
with-timezone-p (format-timezone zone))))))
(defun parse-iso-time-string (time-string)
"Parse an ISO 8601 formated string and return the universal time.
It can parse the basic and the extended format, but may not be able to
cover all the cases."
(labels ((parse-delimited-string (string delimiter n)
;; Parses a delimited string and returns a list of
;; n integers found in that string.
(let ((answer (make-list n :initial-element 0)))
(loop
for i upfrom 0
for start = 0 then (1+ end)
for end = (position delimiter string :start (1+ start))
do (setf (nth i answer)
(parse-integer (subseq string start end)))
when (null end) return t)
(values-list answer)))
(parse-fixed-field-string (string field-sizes)
;; Parses a string with fixed length fields and returns
;; a list of integers found in that string.
(let ((answer (make-list (length field-sizes) :initial-element 0)))
(loop
with len = (length string)
for start = 0 then (+ start field-size)
for field-size in field-sizes
for i upfrom 0
while (< start len)
do (setf (nth i answer)
(parse-integer (subseq string start (+ start field-size)))))
(values-list answer)))
(parse-iso8601-date (date-string)
(let ((hyphen-pos (position #\- date-string)))
(if hyphen-pos
(parse-delimited-string date-string #\- 3)
(parse-fixed-field-string date-string '(4 2 2)))))
(parse-iso8601-timeonly (time-string)
(let* ((colon-pos (position #\: time-string))
(zone-pos (or (position #\- time-string)
(position #\+ time-string)))
(timeonly-string (subseq time-string 0 zone-pos))
(zone-string (when zone-pos (subseq time-string (1+ zone-pos))))
(time-zone nil))
(when zone-pos
(multiple-value-bind (zone-h zone-m)
(parse-delimited-string zone-string #\: 2)
(setq time-zone (+ zone-h (/ zone-m 60)))
(when (char= (char time-string zone-pos) #\-)
(setq time-zone (- time-zone)))))
(multiple-value-bind (hh mm ss)
(if colon-pos
(parse-delimited-string timeonly-string #\: 3)
(parse-fixed-field-string timeonly-string '(2 2 2)))
(values hh mm ss time-zone)))))
(let ((time-separator (position #\T time-string)))
(multiple-value-bind (year month date)
(parse-iso8601-date
(subseq time-string 0 time-separator))
(if time-separator
(multiple-value-bind (hh mm ss zone)
(parse-iso8601-timeonly
(subseq time-string (1+ time-separator)))
(if zone
;; Sign of time zone is reversed in ISO 8601
;; relative to Common Lisp convention!
(encode-universal-time ss mm hh date month year (- zone))
(encode-universal-time ss mm hh date month year)))
(encode-universal-time 0 0 0 date month year))))))
(defun time-string (time &optional time-zone)
"Return a string representing TIME in the form:
Tue Jan 25 12:55:40 2005"
(multiple-value-bind (ss mm hh day month year week-day)
(decode-universal-time time time-zone)
(format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A"
(subseq (week-day->string week-day) 0 3)
(subseq (month->string month) 0 3)
day
hh mm ss
year)))
(defun beginning-of-month (month year &optional time-zone)
(encode-universal-time 0 0 0 1 month year time-zone))
(defun end-of-month (month year &optional time-zone)
(1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone))))
(defun beginning-of-first-week (year &optional time-zone)
"Return the epoch of the first week of YEAR. As the first week
of the year needs to have Thursday in this YEAR, the returned
time can actually fall in the previous year."
(let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone))
(start (- 4 (week-day (add-days 4 Jan-1st)))))
(add-days start Jan-1st)))
(defun beginning-of-week (week year &optional time-zone)
"Return the epoch of the beginning of WEEK of YEAR."
(add-days (* (1- week) 7) (beginning-of-first-week year time-zone)))
(defun end-of-week (week year &optional time-zone)
"Return the epoch of the beginning of WEEK of YEAR."
(1- (beginning-of-week (1+ week) year time-zone)))
(defun end-of-last-week (year &optional time-zone)
"Return the epoch of the last week of YEAR. As the last week
of the year needs to have Thursday in this YEAR, the returned
time can fall in the next year."
(1- (beginning-of-first-week (1+ year) time-zone)))
(defun seconds-from-beginning-of-the-year (time &optional time-zone)
(- time (encode-universal-time 0 0 0 1 1 (year time) time-zone)))
(defun day-of-the-year (time &optional time-zone)
"Return the day within the year of TIME starting from 1 up to
365 (or 366)."
(1+ (truncate (seconds-from-beginning-of-the-year time time-zone)
(* 60 60 24))))
(defun week (time &optional time-zone)
"Return the number of the week and the year TIME referes to.
Week is an integer from 1 to 52. Due to the way the first week
of the year is calculated a day in one year could actually be in
the last week of the previous or next year."
(let* ((year (year time))
(start (beginning-of-first-week year time-zone))
(days-from-start (truncate (- time start) (* 60 60 24)))
(weeks (truncate days-from-start 7))
(week-number (mod weeks 52)))
(values (1+ week-number)
(cond ((< weeks 0)
(1- year))
((> weeks 51)
(1+ year))
(t year)))))
(defun week-day->string (day &optional sunday-first)
"Return the weekday string corresponding to DAY number."
(elt (if sunday-first
#("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")
#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
day))
(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July"
"August" "September" "October" "November" "December"))
(defun month->string (month)
"Return the month string corresponding to MONTH number."
(elt +month-names+ (1- month)))
(defun month-string->number (month)
(1+ (position month +month-names+ :test #'string-equal)))
(defun print-time-span (span &optional stream)
"Print in English the time SPAN expressed in seconds."
(let* ((minute 60)
(hour (* minute 60))
(day (* hour 24))
(seconds span))
(macrolet ((split (divisor)
`(when (>= seconds ,divisor)
(prog1 (truncate seconds ,divisor)
(setf seconds (mod seconds ,divisor))))))
(let* ((days (split day))
(hours (split hour))
(minutes (split minute)))
(format stream "~{~A~^ ~}" (remove nil
(list
(when days
(format nil "~D day~:P" days))
(when hours
(format nil "~D hour~:P" hours))
(when minutes
(format nil "~D minute~:P" minutes))
(when (or (> seconds 0)
(= span 0))
(format nil "~D second~:P" seconds)))))))))
(defun next-week-day (epoch week-day &optional time-zone)
"Return the universal time of the next WEEK-DAY starting from epoch."
(add-days (mod (- week-day (week-day epoch time-zone)) 7)
epoch))
(defun next-monday (epoch &optional time-zone)
"Return the universal time of the next Monday starting from
EPOCH."
(next-week-day epoch 0 time-zone))
(defun full-weeks-in-span (start end &optional time-zone)
"Return the number of full weeks in time span START to END. A
full week starts on Monday and ends on Sunday."
(be first-monday (next-monday start time-zone)
(truncate (- end first-monday) (* 7 24 60 60))))
(defconst +unix-lisp-time-difference+
(encode-universal-time 0 0 0 1 1 1970 0)
"Time difference between Unix epoch and Common Lisp epoch. The
former is 1st January 1970, while the latter is the beginning of the
XX century.")
(defun universal->unix-time (time)
(- time +unix-lisp-time-difference+))
(defun unix->universal-time (time)
(+ time +unix-lisp-time-difference+))
(defun get-unix-time ()
(universal->unix-time (get-universal-time)))

16
users/sterni/mblog/mblog.lisp
View file

@ -1,7 +1,23 @@
;; SPDX-License-Identifier: MIT AND LGPL-2.1-or-later
;; SPDX-FileCopyrightText: Copyright (C) 2006-2010 by Walter C. Pelissero
;; SPDX-FileCopyrightText: Copyright (C) 2022 by sterni
(in-package :mblog)
;; util
;; Taken from SCLF, written by Walter C. Pelissero
(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))
(defmacro with-overwrite-file ((&rest args) &body body)
"Like WITH-OPEN-FILE, but creates/supersedes the given file for writing."
`(with-open-file (,@args :direction :output

1
users/sterni/mblog/packages.lisp
View file

@ -36,7 +36,6 @@
:note)
(:export :build-mblog)
(:import-from :local-time :universal-to-timestamp)
(:import-from :sclf :pathname-as-directory)
(:shadowing-import-from :common-lisp :list))
(defpackage :cli