maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

style(3p/lisp): expand tabs in npg, mime4cl and sclf

Browse source 
Done using

    find third_party/lisp/{sclf,mime4cl,npg} \
      -name '*.lisp' -or -name '*.asd' \
      -exec bash -c 'expand -i -t 8 "$0" | sponge "$0"' {} \;

Change-Id: If84afac9c1d5cbc74e137a5aa0ae61472f0f1e90
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5066
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
This commit is contained in:
sterni 2022-01-19 14:39:58 +01:00
parent 40014c70b3
commit 25cb0ad32f
25 changed files with 2467 additions and 2467 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -29,25 +29,25 @@
(setf pathname (pathname pathname))
(if (pathname-name pathname)
(make-pathname :directory (append (or (pathname-directory pathname)
'(:relative))
(list (file-namestring pathname)))
:name nil
:type nil
:defaults pathname)
'(:relative))
(list (file-namestring pathname)))
:name nil
:type nil
:defaults pathname)
pathname))
(defun d+ (path &rest rest)
"Concatenate directory pathname parts and return a pathname."
(make-pathname :defaults path
:directory (append (pathname-directory path) rest)))
:directory (append (pathname-directory path) rest)))
(defun delete-directory (pathname)
"Remove directory PATHNAME. Return PATHNAME."
#+cmu (multiple-value-bind (done errno)
(unix:unix-rmdir (namestring pathname))
(unless done
(error "Unable to delete directory ~A (errno=~A)"
pathname errno)))
(unix:unix-rmdir (namestring pathname))
(unless done
(error "Unable to delete directory ~A (errno=~A)"
pathname errno)))
#+sbcl (sb-posix:rmdir pathname)
#+lispworks (lw:delete-directory pathname)
#-(or cmu sbcl)
@ -60,11 +60,11 @@ to follow symbolic links."
#-(or sbcl cmu) (declare (ignore truenamep))
(let (#+cmu (lisp::*ignore-wildcards* t))
(directory (make-pathname :defaults (pathname-as-directory pathname)
:name :wild
:type :wild
:version :wild)
#+cmu :truenamep #+cmu truenamep
#+sbcl :resolve-symlinks #+sbcl truenamep)))
:name :wild
:type :wild
:version :wild)
#+cmu :truenamep #+cmu truenamep
#+sbcl :resolve-symlinks #+sbcl truenamep)))
(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first)
"Call PROC on all pathnames under ROOT-PATHNAME, both files and
@ -76,42 +76,42 @@ broken symbolic links in your filesystem."
(check-type proc (or function symbol))
(check-type test (or function symbol null))
(labels ((ls (dir)
(declare (type pathname dir))
(list-directory dir :truenamep truenamep))
(traverse? (file)
(declare (type pathname file))
(and (not (pathname-name file))
(or truenamep
(not (symbolic-link-p file)))
(or (not test)
(funcall test file))))
(traverse-pre-order (dir)
(declare (type pathname dir))
(loop
for file in (ls dir)
do (funcall proc file)
when (traverse? file)
do (traverse-pre-order file)))
(traverse-post-order (dir)
(declare (type pathname dir))
(loop
for file in (ls dir)
when (traverse? file)
do (traverse-post-order file)
do (funcall proc file))))
(declare (type pathname dir))
(list-directory dir :truenamep truenamep))
(traverse? (file)
(declare (type pathname file))
(and (not (pathname-name file))
(or truenamep
(not (symbolic-link-p file)))
(or (not test)
(funcall test file))))
(traverse-pre-order (dir)
(declare (type pathname dir))
(loop
for file in (ls dir)
do (funcall proc file)
when (traverse? file)
do (traverse-pre-order file)))
(traverse-post-order (dir)
(declare (type pathname dir))
(loop
for file in (ls dir)
when (traverse? file)
do (traverse-post-order file)
do (funcall proc file))))
(if depth-first
(traverse-post-order root-pathname)
(traverse-pre-order root-pathname))
(traverse-post-order root-pathname)
(traverse-pre-order root-pathname))
(values)))
(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body)
"Call TRAVERSE-DIRECTORY-TREE with BODY es procedure."
`(traverse-directory-tree ,root-pathname
#'(lambda (,file)
,@body)
:truenamep ,truenamep
:test ,test
:depth-first ,depth-first))
#'(lambda (,file)
,@body)
:truenamep ,truenamep
:test ,test
:depth-first ,depth-first))
(defun empty-directory-p (pathname)
(and (directory-p pathname)
@ -142,7 +142,7 @@ system.)"
(be files '()
(do-directory-tree (file root-pathname :truenamep truenamep)
(when (funcall matcher-function file)
(push file files)))
(push file files)))
(nreverse files)))
(defun delete-directory-tree (pathname)
@ -156,17 +156,17 @@ this function in your programs."
(if (pathname-name pathname)
(delete-file pathname)
(progn
(dolist (file (list-directory pathname))
(delete-directory-tree file))
(delete-directory pathname))))
(dolist (file (list-directory pathname))
(delete-directory-tree file))
(delete-directory pathname))))
(defun make-directory (pathname &optional (mode #o777))
"Create a new directory in the filesystem. Permissions MODE
will be assigned to it. Return PATHNAME."
#+cmu (multiple-value-bind (done errno)
(unix:unix-mkdir (native-namestring pathname) mode)
(unless done
(error "Unable to create directory ~A (errno=~A)." pathname errno)))
(unix:unix-mkdir (native-namestring pathname) mode)
(unless done
(error "Unable to create directory ~A (errno=~A)." pathname errno)))
#+sbcl (sb-posix:mkdir pathname mode)
#-(or cmu sbcl)
(error "MAKE-DIRECTORY is not implemented for this Lisp system.")
@ -180,19 +180,19 @@ will be assigned to it. Return PATHNAME."
"Just like ENSURE-DIRECTORIES-EXIST but, in some situations,
it's faster."
(labels ((ensure (path)
(unless (probe-file path)
(be* tail (last (pathname-directory path) 2)
last (cdr tail)
(setf (cdr tail) nil)
(unwind-protect
(ensure path)
(setf (cdr tail) last))
(make-directory path mode)
(when verbose
(format t "Created ~S~%" path))))))
(unless (probe-file path)
(be* tail (last (pathname-directory path) 2)
last (cdr tail)
(setf (cdr tail) nil)
(unwind-protect
(ensure path)
(setf (cdr tail) last))
(make-directory path mode)
(when verbose
(format t "Created ~S~%" path))))))
(ensure (make-pathname :defaults pathname
:name nil :type nil
:version nil))))
:name nil :type nil
:version nil))))
(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777))
"Create a new directory and return its pathname.
@ -212,7 +212,7 @@ BODY returns. BODY is _not_ executed within the PATH directory; the
working directory is never changed."
`(be ,path (make-temp-directory ,@make-temp-directory-args)
(unwind-protect
(progn ,@body)
(progn ,@body)
(delete-directory-tree ,path))))
(defun current-directory ()
@ -229,44 +229,44 @@ are defined."
;; we should discard and replace whatever has been defined in any
;; rc file during compilation
(setf (logical-pathname-translations "home")
(list
(list "**;*.*.*"
(make-pathname :defaults home
:directory (append (pathname-directory home)
'(:wild-inferiors))
:name :wild
:type :wild))))))
(list
(list "**;*.*.*"
(make-pathname :defaults home
:directory (append (pathname-directory home)
'(:wild-inferiors))
:name :wild
:type :wild))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
&key (start 0) end junk-allowed)
#+sbcl (sb-ext:parse-native-namestring string host defaults
:start start
:end end
:junk-allowed junk-allowed)
:start start
:end end
:junk-allowed junk-allowed)
#-sbcl (let (#+cmu(lisp::*ignore-wildcards* t))
(parse-namestring string host defaults
:start start
:end end
:junk-allowed junk-allowed)))
(parse-namestring string host defaults
:start start
:end end
:junk-allowed junk-allowed)))
(defun native-namestring (pathname)
#+sbcl (sb-ext:native-namestring pathname)
#-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
(namestring pathname)))
(namestring pathname)))
(defun native-file-namestring (pathname)
#+sbcl (sb-ext:native-namestring
(make-pathname :name (pathname-name pathname)
:type (pathname-type pathname)))
(make-pathname :name (pathname-name pathname)
:type (pathname-type pathname)))
#+cmu (be lisp::*ignore-wildcards* t
(file-namestring pathname)))
(file-namestring pathname)))
(defun native-pathname (thing)
#+sbcl (sb-ext:native-pathname thing)
#+cmu (be lisp::*ignore-wildcards* t
(pathname thing)))
(pathname thing)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -277,9 +277,9 @@ are defined."
(defun directory-p (pathname)
"Return true if PATHNAME names a directory on the filesystem."
#-clisp (awhen (unix-stat (native-namestring pathname))
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-ifdir
#+cmu unix:s-ifdir))
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-ifdir
#+cmu unix:s-ifdir))
#+clisp (ext:probe-directory (pathname-as-directory pathname)))
(defun regular-file-p (pathname)
@ -287,8 +287,8 @@ are defined."
#-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file")
(awhen (unix-stat (native-namestring pathname))
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-ifreg
#+cmu unix:s-ifreg)))
#+sbcl sb-posix:s-ifreg
#+cmu unix:s-ifreg)))
(defun file-readable-p (pathname)
#+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok)
@ -324,27 +324,27 @@ are defined."
(defun unix-stat (pathname)
;; this could be different depending on the unix systems
(multiple-value-bind (ok? device inode mode links uid gid rdev
size atime mtime ctime
blksize blocks)
size atime mtime ctime
blksize blocks)
(#+cmu unix:unix-lstat
#+sbcl sb-unix:unix-lstat
(if (stringp pathname)
pathname
(native-namestring pathname)))
pathname
(native-namestring pathname)))
(declare (ignore rdev))
(when ok?
(make-unix-file-stat :device device
:inode inode
:links links
:atime atime
:mtime mtime
:ctime ctime
:size size
:blksize blksize
:blocks blocks
:uid uid
:gid gid
:mode mode))))
:inode inode
:links links
:atime atime
:mtime mtime
:ctime ctime
:size size
:blksize blksize
:blocks blocks
:uid uid
:gid gid
:mode mode))))
(defun stat-modification-time (stat)
"Return the modification time of the STAT structure as Lisp
@ -383,9 +383,9 @@ contents."
(defun symbolic-link-p (pathname)
#-(or sbcl cmu) (error "don't know hot to test for symbolic links.")
(aand (unix-stat pathname)
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-iflnk
#+cmu unix:s-iflnk)))
(bits-set-p (stat-mode it)
#+sbcl sb-posix:s-iflnk
#+cmu unix:s-iflnk)))
(defun broken-link-p (pathname)
(when (symbolic-link-p pathname)

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

@ -41,13 +41,13 @@
(if (forced-p promise)
(promise-value promise)
(prog1 (setf (promise-value promise)
(funcall (promise-procedure promise)))
(setf (promise-procedure promise) nil))))
(funcall (promise-procedure promise)))
(setf (promise-procedure promise) nil))))
(defmacro deflazy (name value &optional documentation)
`(defparameter ,name (lazy ,value)
,@(when documentation
(list documentation))))
(list documentation))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -71,8 +71,8 @@ any other."))
(defclass lazy-slot-mixin ()
((lazy-function :initarg :lazy
:reader lazy-slot-function
:initform nil))
:reader lazy-slot-function
:initform nil))
(:documentation
"Slot for LAZY-METACLASS classes. Lazy slots must be declared with
the argument :LAZY which must be a function accepting the object
@ -100,20 +100,20 @@ instance as argument."))
(let ((ds (car direct-slots)))
(if (typep ds 'lazy-direct-slot-definition)
(let ((form (lazy-slot-function ds))
(args (call-next-method)))
(when (or (getf args :initarg)
(getf args :initform))
(error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds))
(list* :lazy
(cond ((and (listp form)
(eq 'lambda (car form)))
(compile nil form))
((symbolp form)
form)
(t (compile nil `(lambda (self)
(declare (ignorable self))
,form))))
args))
(args (call-next-method)))
(when (or (getf args :initarg)
(getf args :initform))
(error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds))
(list* :lazy
(cond ((and (listp form)
(eq 'lambda (car form)))
(compile nil form))
((symbolp form)
form)
(t (compile nil `(lambda (self)
(declare (ignorable self))
,form))))
args))
(call-next-method))))
(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin))
@ -122,7 +122,7 @@ instance as argument."))
;; instance and memoize the value in the slot.
(unless (slot-boundp-using-class class instance slot)
(setf (slot-value-using-class class instance slot)
(funcall (lazy-slot-function slot) instance)))
(funcall (lazy-slot-function slot) instance)))
(call-next-method))
(defun reset-lazy-slots (object)
@ -131,4 +131,4 @@ re-evaluated next time their value is requested again."
(be* class (class-of object)
(dolist (slot (class-slots class))
(when (typep slot 'lazy-effective-slot-definition)
(slot-makunbound object (slot-definition-name slot))))))
(slot-makunbound object (slot-definition-name slot))))))

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

@ -30,14 +30,14 @@
(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms)
`(mp:with-lock-held (,lock ,(or whostate "Lock Wait")
:wait wait
,@(when timeout (list :timeout timeout)))
:wait wait
,@(when timeout (list :timeout timeout)))
,@forms))
(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms)
`(mp:with-lock-held (,lock
,@(when wait (list :wait wait))
,@(when timeout (list :timeout timeout)))
,@(when wait (list :wait wait))
,@(when timeout (list :timeout timeout)))
,@forms))
(defstruct condition-variable
@ -47,31 +47,31 @@
(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp
#+i486 (kernel:%instance-set-conditional
lock 2 mp:*current-process* nil)
lock 2 mp:*current-process* nil)
#-i486 (when (eq (lock-process lock) mp:*current-process*)
(setf (lock-process lock) nil)))
(setf (lock-process lock) nil)))
(defun condition-wait (cv lock &optional timeout)
(declare (ignore timeout)) ;For now
(loop
(let ((cv-lock (condition-variable-lock cv)))
(with-lock-held (cv-lock)
(when (condition-variable-value cv)
(setf (condition-variable-value cv) nil)
(return-from condition-wait t))
(setf (condition-variable-process-queue cv)
(nconc (condition-variable-process-queue cv)
(list mp:*current-process*)))
(%release-lock lock))
(when (condition-variable-value cv)
(setf (condition-variable-value cv) nil)
(return-from condition-wait t))
(setf (condition-variable-process-queue cv)
(nconc (condition-variable-process-queue cv)
(list mp:*current-process*)))
(%release-lock lock))
(mp:process-add-arrest-reason mp:*current-process* cv)
(let ((cv-val nil))
(with-lock-held (cv-lock)
(setq cv-val (condition-variable-value cv))
(when cv-val
(setf (condition-variable-value cv) nil)))
(when cv-val
(mp::lock-wait lock "waiting for condition variable lock")
(return-from condition-wait t))))))
(with-lock-held (cv-lock)
(setq cv-val (condition-variable-value cv))
(when cv-val
(setf (condition-variable-value cv) nil)))
(when cv-val
(mp::lock-wait lock "waiting for condition variable lock")
(return-from condition-wait t))))))
(defun condition-notify (cv)
(with-lock-held ((condition-variable-lock cv))
@ -79,12 +79,12 @@
;; The waiting process may have released the CV lock but not
;; suspended itself yet
(when proc
(loop
for activep = (mp:process-active-p proc)
while activep
do (mp:process-yield))
(setf (condition-variable-value cv) t)
(mp:process-revoke-arrest-reason proc cv))))
(loop
for activep = (mp:process-active-p proc)
while activep
do (mp:process-yield))
(setf (condition-variable-value cv) t)
(mp:process-revoke-arrest-reason proc cv))))
;; Give the other process a chance
(mp:process-yield))
@ -100,7 +100,7 @@
(defun destroy-process (process)
;; silnetly ignore a process that is trying to destroy itself
(unless (eq (mp:current-process)
process)
process)
(mp:destroy-process process)))
(defun restart-process (process)

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

@ -24,8 +24,8 @@
(in-package :sclf)
(defstruct (process
(:constructor %make-process)
(:predicate processp))
(:constructor %make-process)
(:predicate processp))
name
state
whostate
@ -53,10 +53,10 @@
(defmacro get-mutex (mutex &optional (wait t))
`(
#+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
sb-thread:grab-mutex
#-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
sb-thread:get-mutex
,mutex :waitp ,wait))
sb-thread:grab-mutex
#-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
sb-thread:get-mutex
,mutex :waitp ,wait))
(defvar *permanent-queue*
(sb-thread:make-mutex :name "Lock for disabled threads"))
@ -65,7 +65,7 @@
(defun make-process (function &key name)
(let ((p (%make-process :name name
:function function)))
:function function)))
(sb-thread:with-mutex (*all-processes-lock*)
(pushnew p *all-processes*))
(restart-process p)))
@ -73,7 +73,7 @@
(defun process-kill-thread (process)
(let ((thread (process-thread process)))
(when (and thread
(sb-thread:thread-alive-p thread))
(sb-thread:thread-alive-p thread))
(assert (not (eq thread sb-thread:*current-thread*)))
(sb-thread:terminate-thread thread)
;; Wait until all the clean-up forms are done.
@ -85,13 +85,13 @@
(defun restart-process (p)
(labels ((boing ()
(let ((*current-process* p)
(function (process-function p)))
(when function
(funcall function)))))
(let ((*current-process* p)
(function (process-function p)))
(when function
(funcall function)))))
(process-kill-thread p)
(when (setf (process-thread p)
(sb-thread:make-thread #'boing :name (process-name p)))
(sb-thread:make-thread #'boing :name (process-name p)))
p)))
(defun destroy-process (process)
@ -115,26 +115,26 @@
(defun process-wait (reason predicate)
(let ((old-state (process-whostate *current-process*)))
(unwind-protect
(progn
(setf old-state (process-whostate *current-process*)
(process-whostate *current-process*) reason)
(until (funcall predicate)
(process-yield)))
(progn
(setf old-state (process-whostate *current-process*)
(process-whostate *current-process*) reason)
(until (funcall predicate)
(process-yield)))
(setf (process-whostate *current-process*) old-state))))
(defun process-wait-with-timeout (reason timeout predicate)
(let ((old-state (process-whostate *current-process*))
(end-time (+ (get-universal-time) timeout)))
(end-time (+ (get-universal-time) timeout)))
(unwind-protect
(progn
(setf old-state (process-whostate *current-process*)
(process-whostate *current-process*) reason)
(loop
for result = (funcall predicate)
until (or result
(> (get-universal-time) end-time))
do (process-yield)
finally (return result)))
(progn
(setf old-state (process-whostate *current-process*)
(process-whostate *current-process*) reason)
(loop
for result = (funcall predicate)
until (or result
(> (get-universal-time) end-time))
do (process-yield)
finally (return result)))
(setf (process-whostate *current-process*) old-state))))
(defun process-interrupt (process function)
@ -175,13 +175,13 @@
(let ((old-state (gensym "OLD-STATE")))
`(sb-thread:with-mutex (,place :wait-p ,wait)
(let (,old-state)
(unwind-protect
(progn
(when ,state
(setf ,old-state (process-state *current-process*))
(setf (process-state *current-process*) ,state))
,@body)
(setf (process-state *current-process*) ,old-state))))))
(unwind-protect
(progn
(when ,state
(setf ,old-state (process-state *current-process*))
(setf (process-state *current-process*) ,state))
,@body)
(setf (process-state *current-process*) ,old-state))))))
(defun make-recursive-lock (&optional name)
@ -193,24 +193,24 @@
`(sb-thread:with-recursive-lock (,place)
(let (,old-state)
(unwind-protect
(progn
(when ,state
(setf ,old-state (process-state *current-process*))
(setf (process-state *current-process*) ,state))
,@body)
(setf (process-state *current-process*) ,old-state))))))
(progn
(when ,state
(setf ,old-state (process-state *current-process*))
(setf (process-state *current-process*) ,state))
,@body)
(setf (process-state *current-process*) ,old-state))))))
(defun make-condition-variable () (sb-thread:make-waitqueue))
(defun condition-wait (cv lock &optional timeout)
(if timeout
(handler-case
(sb-ext:with-timeout timeout
(sb-thread:condition-wait cv lock)
t)
(sb-ext:timeout (c)
(declare (ignore c))
nil))
(sb-ext:with-timeout timeout
(sb-thread:condition-wait cv lock)
t)
(sb-ext:timeout (c)
(declare (ignore c))
nil))
(progn (sb-thread:condition-wait cv lock) t)))
(defun condition-notify (cv)

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

@ -25,234 +25,234 @@
(defpackage :sclf
(:use :common-lisp
;; we need the MOP for lazy.lisp and serial.lisp
#+cmu :pcl
#+sbcl :sb-mop)
;; we need the MOP for lazy.lisp and serial.lisp
#+cmu :pcl
#+sbcl :sb-mop)
;; Don't know why but compute-effective-slot-definition-initargs is
;; internal in both CMUCL and SBCL
(:import-from #+cmu"PCL" #+sbcl"SB-PCL"
#-(or cmu sbcl) "CLOS"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS")
#-(or cmu sbcl) "CLOS"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS")
#+cmu (:import-from :mp
#:make-process
#:current-process
#:all-processes
#:processp
#:process-name
#:process-state
#:process-whostate
#:process-wait
#:process-wait-with-timeout
#:process-yield
#:process-interrupt
#:disable-process
#:enable-process
#:without-scheduling
#:atomic-incf
#:atomic-decf
#:process-property-list)
#:make-process
#:current-process
#:all-processes
#:processp
#:process-name
#:process-state
#:process-whostate
#:process-wait
#:process-wait-with-timeout
#:process-yield
#:process-interrupt
#:disable-process
#:enable-process
#:without-scheduling
#:atomic-incf
#:atomic-decf
#:process-property-list)
(:export #:be #:be*
#:defconst
#:with-gensyms
#:d+
#:s+
#:f++
#:list->string
#:string-starts-with #:string-ends-with
#:aif #:awhen #:acond #:aand #:acase #:it
#:+whitespace+
#:string-trim-whitespace
#:string-right-trim-whitespace
#:string-left-trim-whitespace
#:whitespace-p #:seq-whitespace-p
#:not-empty
#:position-any
#:+month-names+
#:find-any
#:split-at
#:split-string-at-char
#:week-day->string
#:month->string
#:month-string->number
#:add-months #:add-days
#:read-whole-stream
#:read-file #:write-file #:read-lines
#:read-from-file #:write-to-file
#:string-concat
#:gcase
#:string-truncate
#:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots
#:copy-stream #:copy-file
#:symlink-file
#:keywordify
#:until
#:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year
#:beginning-of-week #:end-of-week
#:next-week-day #:next-monday #:full-weeks-in-span
#:beginning-of-first-week #:end-of-last-week
#:beginning-of-month #:end-of-month
#:locate-system-program
#:*tmp-file-defaults*
#:temp-file-name
#:open-temp-file
#:with-temp-file
#:file-size
#:getenv
#:with-system-environment
#:time-string #:iso-time-string #:parse-iso-time-string
#:soundex
#:string-soundex=
#:lru-cache
#:getcache #:cached
#:print-time-span
#:double-linked-list #:limited-list #:sorted-list
#:insert #:size
#:heap #:heap-add #:heap-pop #:heap-empty-p
#:double-linked-element #:make-double-linked-element #:double-linked-element-p
#:dle-previous #:dle-next #:dle-value
#:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle*
#:sl-map #:do-dll #:do-dll*
#:dll-find #:dll-find-cursor
#:push-first #:push-last #:dll-remove
#:pop-first #:pop-last
#:leap-year-p #:last-day-of-month
#:getuid #:setuid #:with-euid
#:get-logname #:get-user-name #:get-user-home #:find-uid
#:super-user-p
#:pathname-as-directory #:pathname-as-file
#:alist->plist #:plist->alist
#:byte-vector->string
#:string->byte-vector
#:outdated-p
#:with-hidden-temp-file
#:let-places #:let-slots
#:*decimal-point*
#:*thousands-comma*
#:format-amount #:parse-amount
#:with-package
#:make-directory #:ensure-directory
#:make-temp-directory
#:with-temp-directory
#:delete-directory
#:delete-directory-tree
#:do-directory-tree
#:traverse-directory-tree
#:empty-directory-p
#:remove-empty-directories
#:map-directory-tree
#:find-files
#:directory-p
#:regular-file-p
#:file-readable-p
#:file-writable-p
#:file-executable-p
#:current-directory
#:ensure-home-translations
#:list-directory
#:string-escape
#:string-substitute
#:bytes-simple-string
#:make-lock-files
#:with-lock-files
#:getpid
#:on-error
#:floor-to
#:round-to
#:ceiling-to
#:insert-in-order
#:forget-documentation
#:load-compiled
#:swap
#:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p
#:unix-stat #:unix-file-stat
#:stat-device
#:stat-inode
#:stat-links
#:stat-atime
#:stat-mtime
#:stat-ctime
#:stat-birthtime
#:stat-size
#:stat-blksize
#:stat-blocks
#:stat-uid
#:stat-gid
#:stat-mode
#:save-file-excursion
#:stat-modification-time
#:stat-creation-time
#:file-modification-time
#:file-creation-time
#:show
#:memoize-function
#:memoized
#:defun-memoized
#:parse-native-namestring
#:native-file-namestring
#:native-namestring
#:native-pathname
#:read-symbolic-link
#:symbolic-link-p
#:broken-link-p
#:circular-list
#:last-member
#:glob->regex
#:universal->unix-time #:unix->universal-time
#:get-unix-time
#:move-file
#:defconst
#:with-gensyms
#:d+
#:s+
#:f++
#:list->string
#:string-starts-with #:string-ends-with
#:aif #:awhen #:acond #:aand #:acase #:it
#:+whitespace+
#:string-trim-whitespace
#:string-right-trim-whitespace
#:string-left-trim-whitespace
#:whitespace-p #:seq-whitespace-p
#:not-empty
#:position-any
#:+month-names+
#:find-any
#:split-at
#:split-string-at-char
#:week-day->string
#:month->string
#:month-string->number
#:add-months #:add-days
#:read-whole-stream
#:read-file #:write-file #:read-lines
#:read-from-file #:write-to-file
#:string-concat
#:gcase
#:string-truncate
#:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots
#:copy-stream #:copy-file
#:symlink-file
#:keywordify
#:until
#:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year
#:beginning-of-week #:end-of-week
#:next-week-day #:next-monday #:full-weeks-in-span
#:beginning-of-first-week #:end-of-last-week
#:beginning-of-month #:end-of-month
#:locate-system-program
#:*tmp-file-defaults*
#:temp-file-name
#:open-temp-file
#:with-temp-file
#:file-size
#:getenv
#:with-system-environment
#:time-string #:iso-time-string #:parse-iso-time-string
#:soundex
#:string-soundex=
#:lru-cache
#:getcache #:cached
#:print-time-span
#:double-linked-list #:limited-list #:sorted-list
#:insert #:size
#:heap #:heap-add #:heap-pop #:heap-empty-p
#:double-linked-element #:make-double-linked-element #:double-linked-element-p
#:dle-previous #:dle-next #:dle-value
#:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle*
#:sl-map #:do-dll #:do-dll*
#:dll-find #:dll-find-cursor
#:push-first #:push-last #:dll-remove
#:pop-first #:pop-last
#:leap-year-p #:last-day-of-month
#:getuid #:setuid #:with-euid
#:get-logname #:get-user-name #:get-user-home #:find-uid
#:super-user-p
#:pathname-as-directory #:pathname-as-file
#:alist->plist #:plist->alist
#:byte-vector->string
#:string->byte-vector
#:outdated-p
#:with-hidden-temp-file
#:let-places #:let-slots
#:*decimal-point*
#:*thousands-comma*
#:format-amount #:parse-amount
#:with-package
#:make-directory #:ensure-directory
#:make-temp-directory
#:with-temp-directory
#:delete-directory
#:delete-directory-tree
#:do-directory-tree
#:traverse-directory-tree
#:empty-directory-p
#:remove-empty-directories
#:map-directory-tree
#:find-files
#:directory-p
#:regular-file-p
#:file-readable-p
#:file-writable-p
#:file-executable-p
#:current-directory
#:ensure-home-translations
#:list-directory
#:string-escape
#:string-substitute
#:bytes-simple-string
#:make-lock-files
#:with-lock-files
#:getpid
#:on-error
#:floor-to
#:round-to
#:ceiling-to
#:insert-in-order
#:forget-documentation
#:load-compiled
#:swap
#:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p
#:unix-stat #:unix-file-stat
#:stat-device
#:stat-inode
#:stat-links
#:stat-atime
#:stat-mtime
#:stat-ctime
#:stat-birthtime
#:stat-size
#:stat-blksize
#:stat-blocks
#:stat-uid
#:stat-gid
#:stat-mode
#:save-file-excursion
#:stat-modification-time
#:stat-creation-time
#:file-modification-time
#:file-creation-time
#:show
#:memoize-function
#:memoized
#:defun-memoized
#:parse-native-namestring
#:native-file-namestring
#:native-namestring
#:native-pathname
#:read-symbolic-link
#:symbolic-link-p
#:broken-link-p
#:circular-list
#:last-member
#:glob->regex
#:universal->unix-time #:unix->universal-time
#:get-unix-time
#:move-file
;; sysproc.lisp
#:*run-verbose*
#:run-pipe
#:run-program
#:run-shell-command
#:run-async-shell-command
#:exit-code
#:with-open-pipe
#:*bourne-shell*
#:sysproc-kill
#:sysproc-input
#:sysproc-output
#:sysproc-alive-p
#:sysproc-pid
#:sysproc-p
#:sysproc-wait
#:sysproc-exit-code
#:sysproc-set-signal-callback
;; sysproc.lisp
#:*run-verbose*
#:run-pipe
#:run-program
#:run-shell-command
#:run-async-shell-command
#:exit-code
#:with-open-pipe
#:*bourne-shell*
#:sysproc-kill
#:sysproc-input
#:sysproc-output
#:sysproc-alive-p
#:sysproc-pid
#:sysproc-p
#:sysproc-wait
#:sysproc-exit-code
#:sysproc-set-signal-callback
;; MP
#:make-process
#:destroy-process
#:current-process
#:all-processes
#:processp
#:process-name
#:process-state
#:process-whostate
#:process-wait
#:process-wait-with-timeout
#:process-yield
#:process-interrupt
#:disable-process
#:enable-process
#:restart-process
#:without-scheduling
#:atomic-incf
#:atomic-decf
#:process-property-list
#:process-alive-p
#:process-join
;;
#:make-lock
#:with-lock-held
#:make-recursive-lock
#:with-recursive-lock-held
;;
#:make-condition-variable
#:condition-wait
#:condition-notify
#:process-property-list
#:process-execute
;; mop.lisp
#:printable-object-mixin
))
;; MP
#:make-process
#:destroy-process
#:current-process
#:all-processes
#:processp
#:process-name
#:process-state
#:process-whostate
#:process-wait
#:process-wait-with-timeout
#:process-yield
#:process-interrupt
#:disable-process
#:enable-process
#:restart-process
#:without-scheduling
#:atomic-incf
#:atomic-decf
#:process-property-list
#:process-alive-p
#:process-join
;;
#:make-lock
#:with-lock-held
#:make-recursive-lock
#:with-recursive-lock-held
;;
#:make-condition-variable
#:condition-wait
#:condition-notify
#:process-property-list
#:process-execute
;; mop.lisp
#:printable-object-mixin
))

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

@ -49,10 +49,10 @@ uses, too small to fit anywhere else."
(:file "directory" :depends-on ("package" "sclf" "time"))
(:file "serial" :depends-on ("package" "sclf"))
(:module "mp"
:depends-on ("package" "sclf")
:components
((:doc-file "README")
(:file #.(first
(list #+cmu "cmu"
#+sbcl "sbcl"
"unknown")))))))
:depends-on ("package" "sclf")
:components
((:doc-file "README")
(:file #.(first
(list #+cmu "cmu"
#+sbcl "sbcl"
"unknown")))))))

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

File diff suppressed because it is too large Load diff

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

@ -33,28 +33,28 @@
(be class (class-of object)
(pprint-logical-block (stream (copy-list (class-slots class)) :prefix "#.(" :suffix ")")
(flet ((spc ()
(write-char #\space stream)))
(write 'reconstruct-object :stream stream)
(spc)
(write (class-name class) :stream stream :escape t :readably t :pretty t)
(pprint-exit-if-list-exhausted)
(spc)
(loop
(be* slot (pprint-pop)
slot-name (slot-definition-name slot)
initarg (car (slot-definition-initargs slot))
(when (and initarg
(slot-boundp object slot-name))
(write initarg :stream stream)
(spc)
(when *print-pretty*
(pprint-newline :miser stream))
(write (slot-value object slot-name)
:stream stream)
(pprint-exit-if-list-exhausted)
(if *print-pretty*
(pprint-newline :linear stream)
(spc)))))))))
(write-char #\space stream)))
(write 'reconstruct-object :stream stream)
(spc)
(write (class-name class) :stream stream :escape t :readably t :pretty t)
(pprint-exit-if-list-exhausted)
(spc)
(loop
(be* slot (pprint-pop)
slot-name (slot-definition-name slot)
initarg (car (slot-definition-initargs slot))
(when (and initarg
(slot-boundp object slot-name))
(write initarg :stream stream)
(spc)
(when *print-pretty*
(pprint-newline :miser stream))
(write (slot-value object slot-name)
:stream stream)
(pprint-exit-if-list-exhausted)
(if *print-pretty*
(pprint-newline :linear stream)
(spc)))))))))
(defmethod print-object ((object printable-object-mixin) stream)
(if *print-readably*

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

@ -66,8 +66,8 @@ error is not discarded.")
#+cmu unix:sigcont
#+sbcl sb-posix:sigcont)
#+freebsd((:emt :emulate-instruction)
#+cmu unix:sigemt
#+sbcl sb-posix:sigemt)
#+cmu unix:sigemt
#+sbcl sb-posix:sigemt)
((:fpe :floating-point-exception)
#+cmu unix:sigfpe
#+sbcl sb-posix:sigfpe)
@ -189,29 +189,29 @@ error is not discarded.")
"Run PROGRAM with ARGUMENTS (a list) and return a process object."
;; convert arguments to strings
(setf arguments
(mapcar #'(lambda (item)
(typecase item
(string item)
(pathname (native-namestring item))
(t (format nil "~A" item))))
arguments))
(mapcar #'(lambda (item)
(typecase item
(string item)
(pathname (native-namestring item))
(t (format nil "~A" item))))
arguments))
(when *run-verbose*
(unless error
(setf error t))
(format t "~&; run-pipe ~A~{ ~S~}~%" program arguments))
#+cmu (ext:run-program program arguments
:wait wait
:pty pty
:input input
:output output
:error (or error *run-verbose*))
:wait wait
:pty pty
:input input
:output output
:error (or error *run-verbose*))
#+sbcl (sb-ext:run-program program arguments
:search t
:wait wait
:pty pty
:input input
:output output
:error (or error *run-verbose*))
:search t
:wait wait
:pty pty
:input input
:output output
:error (or error *run-verbose*))
#-(or sbcl cmu)
(error "Unsupported Lisp system."))
@ -220,16 +220,16 @@ error is not discarded.")
return the input and output streams and process object of that
process."
(be process (run-program program arguments
:wait nil
:pty nil
:input (when (member direction '(:output :input-output :io))
:stream)
:output (when (member direction '(:input :input-output :io))
:stream)
:error error)
:wait nil
:pty nil
:input (when (member direction '(:output :input-output :io))
:stream)
:output (when (member direction '(:input :input-output :io))
:stream)
:error error)
(values (sysproc-output process)
(sysproc-input process)
process))
(sysproc-input process)
process))
#-(or sbcl cmu)
(error "Unsupported Lisp system."))
@ -245,7 +245,7 @@ process."
"Run a Bourne Shell command asynchronously. Return a process
object if provided by your Lisp implementation."
(run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))
:wait nil))
:wait nil))
(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms)
"Run BODY with IN and OUT bound respectively to an input and an
@ -253,36 +253,36 @@ output stream connected to a system process created by running PROGRAM
with ARGUMENTS. If IN or OUT are NIL, then don't create that stream."
(with-gensyms (prg args)
`(be* ,prg ,program
,args ,arguments
,process (run-program ,prg ,args
:output ,(case in
((t nil) in)
(t :stream))
:input ,(case out
((t nil) out)
(t :stream))
:wait nil
:pty ,pty
,@(when error `(:error ,error)))
,args ,arguments
,process (run-program ,prg ,args
:output ,(case in
((t nil) in)
(t :stream))
:input ,(case out
((t nil) out)
(t :stream))
:wait nil
:pty ,pty
,@(when error `(:error ,error)))
(if ,process
(let (,@(case in
((t nil))
(t `((,in (sysproc-output ,process)))))
,@(case out
((t nil))
(t `((,out (sysproc-input ,process))))))
(unwind-protect
(progn
,@forms)
,@(case in
((t nil))
(t `((close ,in))))
,@(case out
((t nil))
(t `((close ,out))))
(when (sysproc-alive-p ,process)
(sysproc-kill ,process :term))))
(error "unable to run ~A~{ ~A~}." ,prg ,args)))))
(let (,@(case in
((t nil))
(t `((,in (sysproc-output ,process)))))
,@(case out
((t nil))
(t `((,out (sysproc-input ,process))))))
(unwind-protect
(progn
,@forms)
,@(case in
((t nil))
(t `((close ,in))))
,@(case out
((t nil))
(t `((close ,out))))
(when (sysproc-alive-p ,process)
(sysproc-kill ,process :term))))
(error "unable to run ~A~{ ~A~}." ,prg ,args)))))
(defun sysproc-set-signal-callback (signal handler)

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

@ -50,15 +50,15 @@
"Return true if YEAR is a leap year."
(and (zerop (mod year 4))
(or (not (zerop (mod year 100)))
(zerop (mod year 400)))))
(zerop (mod year 400)))))
(defun last-day-of-month (month year)
"Return the last day of the month as integer."
(be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month))
(if (and (= last 28)
(leap-year-p year))
(1+ last)
last)))
(leap-year-p year))
(1+ last)
last)))
(defun add-months (months epoch &optional time-zone)
"Add MONTHS to EPOCH, which is a universal time. MONTHS can be
@ -66,12 +66,12 @@ negative."
(multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone)
(multiple-value-bind (y m) (floor (+ month months -1) 12)
(let ((new-month (1+ m))
(new-year (+ year y)))
(encode-universal-time ss mm hh
(min day (last-day-of-month new-month (year epoch)))
new-month
new-year
time-zone)))))
(new-year (+ year y)))
(encode-universal-time ss mm hh
(min day (last-day-of-month new-month (year epoch)))
new-month
new-year
time-zone)))))
(defun add-days (days epoch)
"Add DAYS to EPOCH, which is an universal time. DAYS can be
@ -86,7 +86,7 @@ negative."
"Return an ISO 8601 string representing TIME. The time zone is
included if WITH-TIMEZONE-P is true."
(flet ((format-timezone (zone)
(if (zerop zone)
(if (zerop zone)
"Z"
(multiple-value-bind (h m) (truncate (abs zone) 1.0)
;; Sign of time zone is reversed in ISO 8601 relative
@ -94,82 +94,82 @@ included if WITH-TIMEZONE-P is true."
(format nil "~:[+~;-~]~2,'0D:~2,'0D"
(> zone 0) h (round m))))))
(multiple-value-bind (second minute hour day month year dow dst zone)
(decode-universal-time time time-zone)
(decode-universal-time time time-zone)
(declare (ignore dow dst))
(if basic
(format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]"
year month day hour minute second
with-timezone-p (format-timezone zone))
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
year month day hour minute second
with-timezone-p (format-timezone zone))))))
(format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]"
year month day hour minute second
with-timezone-p (format-timezone zone))
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
year month day hour minute second
with-timezone-p (format-timezone zone))))))
(defun parse-iso-time-string (time-string)
"Parse an ISO 8601 formated string and return the universal time.
It can parse the basic and the extended format, but may not be able to
cover all the cases."
(labels ((parse-delimited-string (string delimiter n)
;; Parses a delimited string and returns a list of
;; n integers found in that string.
(let ((answer (make-list n :initial-element 0)))
(loop
for i upfrom 0
for start = 0 then (1+ end)
for end = (position delimiter string :start (1+ start))
do (setf (nth i answer)
(parse-integer (subseq string start end)))
when (null end) return t)
(values-list answer)))
(parse-fixed-field-string (string field-sizes)
;; Parses a string with fixed length fields and returns
;; a list of integers found in that string.
(let ((answer (make-list (length field-sizes) :initial-element 0)))
(loop
with len = (length string)
for start = 0 then (+ start field-size)
for field-size in field-sizes
for i upfrom 0
while (< start len)
do (setf (nth i answer)
(parse-integer (subseq string start (+ start field-size)))))
(values-list answer)))
(parse-iso8601-date (date-string)
(let ((hyphen-pos (position #\- date-string)))
(if hyphen-pos
(parse-delimited-string date-string #\- 3)
(parse-fixed-field-string date-string '(4 2 2)))))
(parse-iso8601-timeonly (time-string)
(let* ((colon-pos (position #\: time-string))
(zone-pos (or (position #\- time-string)
(position #\+ time-string)))
(timeonly-string (subseq time-string 0 zone-pos))
(zone-string (when zone-pos (subseq time-string (1+ zone-pos))))
(time-zone nil))
(when zone-pos
(multiple-value-bind (zone-h zone-m)
(parse-delimited-string zone-string #\: 2)
(setq time-zone (+ zone-h (/ zone-m 60)))
(when (char= (char time-string zone-pos) #\-)
(setq time-zone (- time-zone)))))
(multiple-value-bind (hh mm ss)
(if colon-pos
(parse-delimited-string timeonly-string #\: 3)
(parse-fixed-field-string timeonly-string '(2 2 2)))
(values hh mm ss time-zone)))))
;; Parses a delimited string and returns a list of
;; n integers found in that string.
(let ((answer (make-list n :initial-element 0)))
(loop
for i upfrom 0
for start = 0 then (1+ end)
for end = (position delimiter string :start (1+ start))
do (setf (nth i answer)
(parse-integer (subseq string start end)))
when (null end) return t)
(values-list answer)))
(parse-fixed-field-string (string field-sizes)
;; Parses a string with fixed length fields and returns
;; a list of integers found in that string.
(let ((answer (make-list (length field-sizes) :initial-element 0)))
(loop
with len = (length string)
for start = 0 then (+ start field-size)
for field-size in field-sizes
for i upfrom 0
while (< start len)
do (setf (nth i answer)
(parse-integer (subseq string start (+ start field-size)))))
(values-list answer)))
(parse-iso8601-date (date-string)
(let ((hyphen-pos (position #\- date-string)))
(if hyphen-pos
(parse-delimited-string date-string #\- 3)
(parse-fixed-field-string date-string '(4 2 2)))))
(parse-iso8601-timeonly (time-string)
(let* ((colon-pos (position #\: time-string))
(zone-pos (or (position #\- time-string)
(position #\+ time-string)))
(timeonly-string (subseq time-string 0 zone-pos))
(zone-string (when zone-pos (subseq time-string (1+ zone-pos))))
(time-zone nil))
(when zone-pos
(multiple-value-bind (zone-h zone-m)
(parse-delimited-string zone-string #\: 2)
(setq time-zone (+ zone-h (/ zone-m 60)))
(when (char= (char time-string zone-pos) #\-)
(setq time-zone (- time-zone)))))
(multiple-value-bind (hh mm ss)
(if colon-pos
(parse-delimited-string timeonly-string #\: 3)
(parse-fixed-field-string timeonly-string '(2 2 2)))
(values hh mm ss time-zone)))))
(let ((time-separator (position #\T time-string)))
(multiple-value-bind (year month date)
(parse-iso8601-date
(subseq time-string 0 time-separator))
(if time-separator
(multiple-value-bind (hh mm ss zone)
(parse-iso8601-timeonly
(subseq time-string (1+ time-separator)))
(if zone
;; Sign of time zone is reversed in ISO 8601
;; relative to Common Lisp convention!
(encode-universal-time ss mm hh date month year (- zone))
(encode-universal-time ss mm hh date month year)))
(encode-universal-time 0 0 0 date month year))))))
(parse-iso8601-date
(subseq time-string 0 time-separator))
(if time-separator
(multiple-value-bind (hh mm ss zone)
(parse-iso8601-timeonly
(subseq time-string (1+ time-separator)))
(if zone
;; Sign of time zone is reversed in ISO 8601
;; relative to Common Lisp convention!
(encode-universal-time ss mm hh date month year (- zone))
(encode-universal-time ss mm hh date month year)))
(encode-universal-time 0 0 0 date month year))))))
(defun time-string (time &optional time-zone)
"Return a string representing TIME in the form:
@ -177,11 +177,11 @@ cover all the cases."
(multiple-value-bind (ss mm hh day month year week-day)
(decode-universal-time time time-zone)
(format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A"
(subseq (week-day->string week-day) 0 3)
(subseq (month->string month) 0 3)
day
hh mm ss
year)))
(subseq (week-day->string week-day) 0 3)
(subseq (month->string month) 0 3)
day
hh mm ss
year)))
(defun beginning-of-month (month year &optional time-zone)
(encode-universal-time 0 0 0 1 month year time-zone))
@ -194,7 +194,7 @@ cover all the cases."
of the year needs to have Thursday in this YEAR, the returned
time can actually fall in the previous year."
(let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone))
(start (- 4 (week-day (add-days 4 Jan-1st)))))
(start (- 4 (week-day (add-days 4 Jan-1st)))))
(add-days start Jan-1st)))
(defun beginning-of-week (week year &optional time-zone)
@ -218,7 +218,7 @@ time can fall in the next year."
"Return the day within the year of TIME starting from 1 up to
365 (or 366)."
(1+ (truncate (seconds-from-beginning-of-the-year time time-zone)
(* 60 60 24))))
(* 60 60 24))))
(defun week (time &optional time-zone)
"Return the number of the week and the year TIME referes to.
@ -226,26 +226,26 @@ Week is an integer from 1 to 52. Due to the way the first week
of the year is calculated a day in one year could actually be in
the last week of the previous or next year."
(let* ((year (year time))
(start (beginning-of-first-week year time-zone))
(days-from-start (truncate (- time start) (* 60 60 24)))
(weeks (truncate days-from-start 7))
(week-number (mod weeks 52)))
(start (beginning-of-first-week year time-zone))
(days-from-start (truncate (- time start) (* 60 60 24)))
(weeks (truncate days-from-start 7))
(week-number (mod weeks 52)))
(values (1+ week-number)
(cond ((< weeks 0)
(1- year))
((> weeks 51)
(1+ year))
(t year)))))
(cond ((< weeks 0)
(1- year))
((> weeks 51)
(1+ year))
(t year)))))
(defun week-day->string (day &optional sunday-first)
"Return the weekday string corresponding to DAY number."
(elt (if sunday-first
#("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")
#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
#("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")
#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
day))
(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July"
"August" "September" "October" "November" "December"))
"August" "September" "October" "November" "December"))
(defun month->string (month)
"Return the month string corresponding to MONTH number."
@ -257,32 +257,32 @@ the last week of the previous or next year."
(defun print-time-span (span &optional stream)
"Print in English the time SPAN expressed in seconds."
(let* ((minute 60)
(hour (* minute 60))
(day (* hour 24))
(seconds span))
(hour (* minute 60))
(day (* hour 24))
(seconds span))
(macrolet ((split (divisor)
`(when (>= seconds ,divisor)
(prog1 (truncate seconds ,divisor)
(setf seconds (mod seconds ,divisor))))))
`(when (>= seconds ,divisor)
(prog1 (truncate seconds ,divisor)
(setf seconds (mod seconds ,divisor))))))
(let* ((days (split day))
(hours (split hour))
(minutes (split minute)))
(format stream "~{~A~^ ~}" (remove nil
(list
(when days
(format nil "~D day~:P" days))
(when hours
(format nil "~D hour~:P" hours))
(when minutes
(format nil "~D minute~:P" minutes))
(when (or (> seconds 0)
(= span 0))
(format nil "~D second~:P" seconds)))))))))
(hours (split hour))
(minutes (split minute)))
(format stream "~{~A~^ ~}" (remove nil
(list
(when days
(format nil "~D day~:P" days))
(when hours
(format nil "~D hour~:P" hours))
(when minutes
(format nil "~D minute~:P" minutes))
(when (or (> seconds 0)
(= span 0))
(format nil "~D second~:P" seconds)))))))))
(defun next-week-day (epoch week-day &optional time-zone)
"Return the universal time of the next WEEK-DAY starting from epoch."
(add-days (mod (- week-day (week-day epoch time-zone)) 7)
epoch))
epoch))
(defun next-monday (epoch &optional time-zone)
"Return the universal time of the next Monday starting from