├── README ├── README.md ├── doc ├── .gitignore ├── Makefile ├── docstrings.lisp ├── docstrings │ ├── fun-periods-current-year.texinfo │ ├── fun-periods-day-of-week.texinfo │ ├── fun-periods-days-in-month.texinfo │ ├── fun-periods-falls-on-weekend-p.texinfo │ ├── fun-periods-find-smallest-resolution.texinfo │ ├── fun-periods-fixed-time.texinfo │ ├── fun-periods-floor-time.texinfo │ └── fun-periods-leapp.texinfo ├── make-tempfiles.sh └── periods.texi ├── parser.lisp ├── periods-series.asd ├── periods-series.lisp ├── periods.asd ├── periods.lisp └── strptime.lisp /README: -------------------------------------------------------------------------------- 1 | Welcome to the PERIODS library. The intention of this code is to provide a 2 | convenient set of utilities for manipulating times, distances between times, 3 | and both contiguous and discontiguous ranges of time. By combining these 4 | facilities in various ways, almost any type of time expression is possible. 5 | 6 | Please see the documentation in doc/ for information. 7 | 8 | John Wiegley 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Welcome to the PERIODS library. The intention of this code is to provide a convenient set of utilities for manipulating times, distances between times, 2 | and both contiguous and discontiguous ranges of time. By combining these facilities in various ways, almost any type of time expression is possible. 3 | 4 | Please see the documentation in doc/ for information. 5 | 6 | This package relies on the [local-time](http://common-lisp.net/project/local-time/) package and provides [series](http://series.sourceforge.net/)-compatible data structures. 7 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | SBCL = sbcl 2 | MODULES = ':PERIODS' 3 | 4 | all: html info 5 | 6 | docstrings: make-tempfiles.sh 7 | @mkdir docstrings 8 | SBCLRUNTIME=$(SBCL) MODULES=$(MODULES) ./make-tempfiles.sh 9 | perl -i -pe 's/periods://g' docstrings/*.texinfo 10 | perl -i -pe 's/^ // if /@lisp/ .. /@end lisp/' docstrings/*.texinfo 11 | perl -i -pe 's/=>/@result{}/ if /@lisp/ .. /@end lisp/' docstrings/*.texinfo 12 | perl -i -pe 's/.../@dots{}/g' docstrings/*.texinfo 13 | 14 | info: periods.info 15 | 16 | periods.info: periods.texi docstrings 17 | makeinfo periods.texi 18 | 19 | html: periods.texi docstrings 20 | makeinfo --html periods.texi 21 | 22 | pdf: periods.texi docstrings 23 | texi2pdf periods.texi 24 | 25 | clean: 26 | rm -f periods.info periods.pdf 27 | rm -fr periods docstrings 28 | -------------------------------------------------------------------------------- /doc/docstrings.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- lisp -*- 2 | 3 | ;;;; A docstring extractor for the sbcl manual. Creates 4 | ;;;; @include-ready documentation from the docstrings of exported 5 | ;;;; symbols of specified packages. 6 | 7 | ;;;; This software is part of the SBCL software system. SBCL is in the 8 | ;;;; public domain and is provided with absolutely no warranty. See 9 | ;;;; the COPYING file for more information. 10 | ;;;; 11 | ;;;; Written by Rudi Schlatte , mangled 12 | ;;;; by Nikodemus Siivola. 13 | 14 | ;;;; TODO 15 | ;;;; * Verbatim text 16 | ;;;; * Quotations 17 | ;;;; * Method documentation untested 18 | ;;;; * Method sorting, somehow 19 | ;;;; * Index for macros & constants? 20 | ;;;; * This is getting complicated enough that tests would be good 21 | ;;;; * Nesting (currently only nested itemizations work) 22 | ;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also 23 | ;;;; easily generated) 24 | 25 | ;;;; FIXME: The description below is no longer complete. This 26 | ;;;; should possibly be turned into a contrib with proper documentation. 27 | 28 | ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): 29 | ;;;; 30 | ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in 31 | ;;;; the argument list of the defun / defmacro. 32 | ;;;; 33 | ;;;; Lines starting with * or - that are followed by intented lines 34 | ;;;; are marked up with @itemize. 35 | ;;;; 36 | ;;;; Lines containing only a SYMBOL that are followed by indented 37 | ;;;; lines are marked up as @table @code, with the SYMBOL as the item. 38 | 39 | (eval-when (:compile-toplevel :load-toplevel :execute) 40 | (require 'sb-introspect)) 41 | 42 | (defpackage :sb-texinfo 43 | (:use :cl :sb-mop) 44 | (:shadow #:documentation) 45 | (:export #:generate-includes #:document-package) 46 | (:documentation 47 | "Tools to generate TexInfo documentation from docstrings.")) 48 | 49 | (in-package :sb-texinfo) 50 | 51 | ;;;; various specials and parameters 52 | 53 | (defvar *texinfo-output*) 54 | (defvar *texinfo-variables*) 55 | (defvar *documentation-package*) 56 | 57 | (defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) 58 | 59 | (defparameter *documentation-types* 60 | '(compiler-macro 61 | function 62 | method-combination 63 | setf 64 | ;;structure ; also handled by `type' 65 | type 66 | variable) 67 | "A list of symbols accepted as second argument of `documentation'") 68 | 69 | (defparameter *character-replacements* 70 | '((#\* . "star") (#\/ . "slash") (#\+ . "plus") 71 | (#\< . "lt") (#\> . "gt")) 72 | "Characters and their replacement names that `alphanumize' uses. If 73 | the replacements contain any of the chars they're supposed to replace, 74 | you deserve to lose.") 75 | 76 | (defparameter *characters-to-drop* '(#\\ #\` #\') 77 | "Characters that should be removed by `alphanumize'.") 78 | 79 | (defparameter *texinfo-escaped-chars* "@{}" 80 | "Characters that must be escaped with #\@ for Texinfo.") 81 | 82 | (defparameter *itemize-start-characters* '(#\* #\-) 83 | "Characters that might start an itemization in docstrings when 84 | at the start of a line.") 85 | 86 | (defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&" 87 | "List of characters that make up symbols in a docstring.") 88 | 89 | (defparameter *symbol-delimiters* " ,.!?;") 90 | 91 | (defparameter *ordered-documentation-kinds* 92 | '(package type structure condition class macro)) 93 | 94 | ;;;; utilities 95 | 96 | (defun flatten (list) 97 | (cond ((null list) 98 | nil) 99 | ((consp (car list)) 100 | (nconc (flatten (car list)) (flatten (cdr list)))) 101 | ((null (cdr list)) 102 | (cons (car list) nil)) 103 | (t 104 | (cons (car list) (flatten (cdr list)))))) 105 | 106 | (defun whitespacep (char) 107 | (find char #(#\tab #\space #\page))) 108 | 109 | (defun setf-name-p (name) 110 | (or (symbolp name) 111 | (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) 112 | 113 | (defgeneric specializer-name (specializer)) 114 | 115 | (defmethod specializer-name ((specializer eql-specializer)) 116 | (list 'eql (eql-specializer-object specializer))) 117 | 118 | (defmethod specializer-name ((specializer class)) 119 | (class-name specializer)) 120 | 121 | (defun ensure-class-precedence-list (class) 122 | (unless (class-finalized-p class) 123 | (finalize-inheritance class)) 124 | (class-precedence-list class)) 125 | 126 | (defun specialized-lambda-list (method) 127 | ;; courtecy of AMOP p. 61 128 | (let* ((specializers (method-specializers method)) 129 | (lambda-list (method-lambda-list method)) 130 | (n-required (length specializers))) 131 | (append (mapcar (lambda (arg specializer) 132 | (if (eq specializer (find-class 't)) 133 | arg 134 | `(,arg ,(specializer-name specializer)))) 135 | (subseq lambda-list 0 n-required) 136 | specializers) 137 | (subseq lambda-list n-required)))) 138 | 139 | (defun string-lines (string) 140 | "Lines in STRING as a vector." 141 | (coerce (with-input-from-string (s string) 142 | (loop for line = (read-line s nil nil) 143 | while line collect line)) 144 | 'vector)) 145 | 146 | (defun indentation (line) 147 | "Position of first non-SPACE character in LINE." 148 | (position-if-not (lambda (c) (char= c #\Space)) line)) 149 | 150 | (defun docstring (x doc-type) 151 | (cl:documentation x doc-type)) 152 | 153 | (defun flatten-to-string (list) 154 | (format nil "~{~A~^-~}" (flatten list))) 155 | 156 | (defun alphanumize (original) 157 | "Construct a string without characters like *`' that will f-star-ck 158 | up filename handling. See `*character-replacements*' and 159 | `*characters-to-drop*' for customization." 160 | (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) 161 | (if (listp original) 162 | (flatten-to-string original) 163 | (string original)))) 164 | (chars-to-replace (mapcar #'car *character-replacements*))) 165 | (flet ((replacement-delimiter (index) 166 | (cond ((or (< index 0) (>= index (length name))) "") 167 | ((alphanumericp (char name index)) "-") 168 | (t "")))) 169 | (loop for index = (position-if #'(lambda (x) (member x chars-to-replace)) 170 | name) 171 | while index 172 | do (setf name (concatenate 'string (subseq name 0 index) 173 | (replacement-delimiter (1- index)) 174 | (cdr (assoc (aref name index) 175 | *character-replacements*)) 176 | (replacement-delimiter (1+ index)) 177 | (subseq name (1+ index)))))) 178 | name)) 179 | 180 | ;;;; generating various names 181 | 182 | (defgeneric name (thing) 183 | (:documentation "Name for a documented thing. Names are either 184 | symbols or lists of symbols.")) 185 | 186 | (defmethod name ((symbol symbol)) 187 | symbol) 188 | 189 | (defmethod name ((cons cons)) 190 | cons) 191 | 192 | (defmethod name ((package package)) 193 | (package-name package)) 194 | 195 | (defmethod name ((method method)) 196 | (list 197 | (generic-function-name (method-generic-function method)) 198 | (method-qualifiers method) 199 | (specialized-lambda-list method))) 200 | 201 | ;;; Node names for DOCUMENTATION instances 202 | 203 | (defgeneric name-using-kind/name (kind name doc)) 204 | 205 | (defmethod name-using-kind/name (kind (name string) doc) 206 | (declare (ignore kind doc)) 207 | name) 208 | 209 | (defmethod name-using-kind/name (kind (name symbol) doc) 210 | (declare (ignore kind)) 211 | (format nil "~A:~A" (package-name (get-package doc)) name)) 212 | 213 | (defmethod name-using-kind/name (kind (name list) doc) 214 | (declare (ignore kind)) 215 | (assert (setf-name-p name)) 216 | (format nil "(setf ~A:~A)" (package-name (get-package doc)) (second name))) 217 | 218 | (defmethod name-using-kind/name ((kind (eql 'method)) name doc) 219 | (format nil "~A~{ ~A~} ~A" 220 | (name-using-kind/name nil (first name) doc) 221 | (second name) 222 | (third name))) 223 | 224 | (defun node-name (doc) 225 | "Returns TexInfo node name as a string for a DOCUMENTATION instance." 226 | (let ((kind (get-kind doc))) 227 | (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) 228 | 229 | ;;; Definition titles for DOCUMENTATION instances 230 | 231 | (defgeneric title-using-kind/name (kind name doc)) 232 | 233 | (defmethod title-using-kind/name (kind (name string) doc) 234 | (declare (ignore kind doc)) 235 | name) 236 | 237 | (defmethod title-using-kind/name (kind (name symbol) doc) 238 | (declare (ignore kind)) 239 | (format nil "~A:~A" (package-name (get-package doc)) name)) 240 | 241 | (defmethod title-using-kind/name (kind (name list) doc) 242 | (declare (ignore kind)) 243 | (assert (setf-name-p name)) 244 | (format nil "(setf ~A:~A)" (package-name (get-package doc)) (second name))) 245 | 246 | (defmethod title-using-kind/name ((kind (eql 'method)) name doc) 247 | (format nil "~{~A ~}~A" 248 | (second name) 249 | (title-using-kind/name nil (first name) doc))) 250 | 251 | (defun title-name (doc) 252 | "Returns a string to be used as name of the definition." 253 | (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) 254 | 255 | (defun include-pathname (doc) 256 | (let* ((kind (get-kind doc)) 257 | (name (nstring-downcase 258 | (if (eq 'package kind) 259 | (format nil "package-~A" (alphanumize (get-name doc))) 260 | (format nil "~A-~A-~A" 261 | (case (get-kind doc) 262 | ((function generic-function) "fun") 263 | (structure "struct") 264 | (variable "var") 265 | (otherwise (symbol-name (get-kind doc)))) 266 | (alphanumize (package-name (get-package doc))) 267 | (alphanumize (get-name doc))))))) 268 | (make-pathname :name name :type "texinfo"))) 269 | 270 | ;;;; documentation class and related methods 271 | 272 | (defclass documentation () 273 | ((name :initarg :name :reader get-name) 274 | (kind :initarg :kind :reader get-kind) 275 | (string :initarg :string :reader get-string) 276 | (children :initarg :children :initform nil :reader get-children) 277 | (package :initform *documentation-package* :reader get-package))) 278 | 279 | (defmethod print-object ((documentation documentation) stream) 280 | (print-unreadable-object (documentation stream :type t) 281 | (princ (list (get-kind documentation) (get-name documentation)) stream))) 282 | 283 | (defgeneric make-documentation (x doc-type string)) 284 | 285 | (defmethod make-documentation ((x package) doc-type string) 286 | (declare (ignore doc-type)) 287 | (make-instance 'documentation 288 | :name (name x) 289 | :kind 'package 290 | :string string)) 291 | 292 | (defmethod make-documentation (x (doc-type (eql 'function)) string) 293 | (declare (ignore doc-type)) 294 | (let* ((fdef (and (fboundp x) (fdefinition x))) 295 | (name x) 296 | (kind (cond ((and (symbolp x) (special-operator-p x)) 297 | 'special-operator) 298 | ((and (symbolp x) (macro-function x)) 299 | 'macro) 300 | ((typep fdef 'generic-function) 301 | (assert (or (symbolp name) (setf-name-p name))) 302 | 'generic-function) 303 | (fdef 304 | (assert (or (symbolp name) (setf-name-p name))) 305 | 'function))) 306 | (children (when (eq kind 'generic-function) 307 | (collect-gf-documentation fdef)))) 308 | (make-instance 'documentation 309 | :name (name x) 310 | :string string 311 | :kind kind 312 | :children children))) 313 | 314 | (defmethod make-documentation ((x method) doc-type string) 315 | (declare (ignore doc-type)) 316 | (make-instance 'documentation 317 | :name (name x) 318 | :kind 'method 319 | :string string)) 320 | 321 | (defmethod make-documentation (x (doc-type (eql 'type)) string) 322 | (make-instance 'documentation 323 | :name (name x) 324 | :string string 325 | :kind (etypecase (find-class x nil) 326 | (structure-class 'structure) 327 | (standard-class 'class) 328 | (sb-pcl::condition-class 'condition) 329 | ((or built-in-class null) 'type)))) 330 | 331 | (defmethod make-documentation (x (doc-type (eql 'variable)) string) 332 | (make-instance 'documentation 333 | :name (name x) 334 | :string string 335 | :kind (if (constantp x) 336 | 'constant 337 | 'variable))) 338 | 339 | (defmethod make-documentation (x (doc-type (eql 'setf)) string) 340 | (declare (ignore doc-type)) 341 | (make-instance 'documentation 342 | :name (name x) 343 | :kind 'setf-expander 344 | :string string)) 345 | 346 | (defmethod make-documentation (x doc-type string) 347 | (make-instance 'documentation 348 | :name (name x) 349 | :kind doc-type 350 | :string string)) 351 | 352 | (defun maybe-documentation (x doc-type) 353 | "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if 354 | there is no corresponding docstring." 355 | (let ((docstring (docstring x doc-type))) 356 | (when docstring 357 | (make-documentation x doc-type docstring)))) 358 | 359 | (defun lambda-list (doc) 360 | (case (get-kind doc) 361 | ((package constant variable type structure class condition nil) 362 | nil) 363 | (method 364 | (third (get-name doc))) 365 | (t 366 | ;; KLUDGE: Eugh. 367 | ;; 368 | ;; believe it or not, the above comment was written before CSR 369 | ;; came along and obfuscated this. (2005-07-04) 370 | (when (symbolp (get-name doc)) 371 | (labels ((clean (x &key optional key) 372 | (typecase x 373 | (atom x) 374 | ((cons (member &optional)) 375 | (cons (car x) (clean (cdr x) :optional t))) 376 | ((cons (member &key)) 377 | (cons (car x) (clean (cdr x) :key t))) 378 | ((cons cons) 379 | (cons 380 | (cond (key (if (consp (caar x)) 381 | (caaar x) 382 | (caar x))) 383 | (optional (caar x)) 384 | (t (clean (car x)))) 385 | (clean (cdr x) :key key :optional optional))) 386 | (cons 387 | (cons 388 | (cond ((or key optional) (car x)) 389 | (t (clean (car x)))) 390 | (clean (cdr x) :key key :optional optional)))))) 391 | (clean (sb-introspect:function-arglist (get-name doc)))))))) 392 | 393 | (defun documentation< (x y) 394 | (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) 395 | (p2 (position (get-kind y) *ordered-documentation-kinds*))) 396 | (if (or (not (and p1 p2)) (= p1 p2)) 397 | (string< (string (get-name x)) (string (get-name y))) 398 | (< p1 p2)))) 399 | 400 | ;;;; turning text into texinfo 401 | 402 | (defun escape-for-texinfo (string &optional downcasep) 403 | "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped 404 | with #\@. Optionally downcase the result." 405 | (let ((result (with-output-to-string (s) 406 | (loop for char across string 407 | when (find char *texinfo-escaped-chars*) 408 | do (write-char #\@ s) 409 | do (write-char char s))))) 410 | (if downcasep (nstring-downcase result) result))) 411 | 412 | (defun empty-p (line-number lines) 413 | (and (< -1 line-number (length lines)) 414 | (not (indentation (svref lines line-number))))) 415 | 416 | ;;; line markups 417 | 418 | (defun locate-symbols (line) 419 | "Return a list of index pairs of symbol-like parts of LINE." 420 | ;; This would be a good application for a regex ... 421 | (do ((result nil) 422 | (begin nil) 423 | (maybe-begin t) 424 | (i 0 (1+ i))) 425 | ((= i (length line)) 426 | ;; symbol at end of line 427 | (when (and begin (or (> i (1+ begin)) 428 | (not (member (char line begin) '(#\A #\I))))) 429 | (push (list begin i) result)) 430 | (nreverse result)) 431 | (cond 432 | ((and begin (find (char line i) *symbol-delimiters*)) 433 | ;; symbol end; remember it if it's not "A" or "I" 434 | (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) 435 | (push (list begin i) result)) 436 | (setf begin nil 437 | maybe-begin t)) 438 | ((and begin (not (find (char line i) *symbol-characters*))) 439 | ;; Not a symbol: abort 440 | (setf begin nil)) 441 | ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) 442 | ;; potential symbol begin at this position 443 | (setf begin i 444 | maybe-begin nil)) 445 | ((find (char line i) *symbol-delimiters*) 446 | ;; potential symbol begin after this position 447 | (setf maybe-begin t)) 448 | (t 449 | ;; Not reading a symbol, not at potential start of symbol 450 | (setf maybe-begin nil))))) 451 | 452 | (defun texinfo-line (line) 453 | "Format symbols in LINE texinfo-style: either as code or as 454 | variables if the symbol in question is contained in symbols 455 | *TEXINFO-VARIABLES*." 456 | (with-output-to-string (result) 457 | (let ((last 0)) 458 | (dolist (symbol/index (locate-symbols line)) 459 | (write-string (subseq line last (first symbol/index)) result) 460 | (let ((symbol-name (apply #'subseq line symbol/index))) 461 | (format result (if (member symbol-name *texinfo-variables* 462 | :test #'string=) 463 | "@var{~A}" 464 | "@code{~A}") 465 | (string-downcase symbol-name))) 466 | (setf last (second symbol/index))) 467 | (write-string (subseq line last) result)))) 468 | 469 | ;;; lisp sections 470 | 471 | (defun lisp-section-p (line line-number lines) 472 | "Returns T if the given LINE looks like start of lisp code -- 473 | ie. if it starts with whitespace followed by a paren or 474 | semicolon, and the previous line is empty" 475 | (let ((offset (indentation line))) 476 | (and offset 477 | (plusp offset) 478 | (find (find-if-not #'whitespacep line) "(;") 479 | (empty-p (1- line-number) lines)))) 480 | 481 | (defun collect-lisp-section (lines line-number) 482 | (let ((lisp (loop for index = line-number then (1+ index) 483 | for line = (and (< index (length lines)) (svref lines index)) 484 | while (indentation line) 485 | collect line))) 486 | (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) 487 | 488 | ;;; itemized sections 489 | 490 | (defun maybe-itemize-offset (line) 491 | "Return NIL or the indentation offset if LINE looks like it starts 492 | an item in an itemization." 493 | (let* ((offset (indentation line)) 494 | (char (when offset (char line offset)))) 495 | (and offset 496 | (member char *itemize-start-characters* :test #'char=) 497 | (char= #\Space (find-if-not (lambda (c) (char= c char)) 498 | line :start offset)) 499 | offset))) 500 | 501 | (defun collect-maybe-itemized-section (lines starting-line) 502 | ;; Return index of next line to be processed outside 503 | (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) 504 | (result nil) 505 | (lines-consumed 0)) 506 | (loop for line-number from starting-line below (length lines) 507 | for line = (svref lines line-number) 508 | for indentation = (indentation line) 509 | for offset = (maybe-itemize-offset line) 510 | do (cond 511 | ((not indentation) 512 | ;; empty line -- inserts paragraph. 513 | (push "" result) 514 | (incf lines-consumed)) 515 | ((and offset (> indentation this-offset)) 516 | ;; nested itemization -- handle recursively 517 | ;; FIXME: tables in itemizations go wrong 518 | (multiple-value-bind (sub-lines-consumed sub-itemization) 519 | (collect-maybe-itemized-section lines line-number) 520 | (when sub-lines-consumed 521 | (incf line-number (1- sub-lines-consumed)) ; +1 on next loop 522 | (incf lines-consumed sub-lines-consumed) 523 | (setf result (nconc (nreverse sub-itemization) result))))) 524 | ((and offset (= indentation this-offset)) 525 | ;; start of new item 526 | (push (format nil "@item ~A" 527 | (texinfo-line (subseq line (1+ offset)))) 528 | result) 529 | (incf lines-consumed)) 530 | ((and (not offset) (> indentation this-offset)) 531 | ;; continued item from previous line 532 | (push (texinfo-line line) result) 533 | (incf lines-consumed)) 534 | (t 535 | ;; end of itemization 536 | (loop-finish)))) 537 | ;; a single-line itemization isn't. 538 | (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) 539 | (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) 540 | nil))) 541 | 542 | ;;; table sections 543 | 544 | (defun tabulation-body-p (offset line-number lines) 545 | (when (< line-number (length lines)) 546 | (let ((offset2 (indentation (svref lines line-number)))) 547 | (and offset2 (< offset offset2))))) 548 | 549 | (defun tabulation-p (offset line-number lines direction) 550 | (let ((step (ecase direction 551 | (:backwards (1- line-number)) 552 | (:forwards (1+ line-number))))) 553 | (when (and (plusp line-number) (< line-number (length lines))) 554 | (and (eql offset (indentation (svref lines line-number))) 555 | (or (when (eq direction :backwards) 556 | (empty-p step lines)) 557 | (tabulation-p offset step lines direction) 558 | (tabulation-body-p offset step lines)))))) 559 | 560 | (defun maybe-table-offset (line-number lines) 561 | "Return NIL or the indentation offset if LINE looks like it starts 562 | an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an 563 | empty line, another tabulation label, or a tabulation body, (3) and 564 | followed another tabulation label or a tabulation body." 565 | (let* ((line (svref lines line-number)) 566 | (offset (indentation line)) 567 | (prev (1- line-number)) 568 | (next (1+ line-number))) 569 | (when (and offset (plusp offset)) 570 | (and (or (empty-p prev lines) 571 | (tabulation-body-p offset prev lines) 572 | (tabulation-p offset prev lines :backwards)) 573 | (or (tabulation-body-p offset next lines) 574 | (tabulation-p offset next lines :forwards)) 575 | offset)))) 576 | 577 | ;;; FIXME: This and itemization are very similar: could they share 578 | ;;; some code, mayhap? 579 | 580 | (defun collect-maybe-table-section (lines starting-line) 581 | ;; Return index of next line to be processed outside 582 | (let ((this-offset (maybe-table-offset starting-line lines)) 583 | (result nil) 584 | (lines-consumed 0)) 585 | (loop for line-number from starting-line below (length lines) 586 | for line = (svref lines line-number) 587 | for indentation = (indentation line) 588 | for offset = (maybe-table-offset line-number lines) 589 | do (cond 590 | ((not indentation) 591 | ;; empty line -- inserts paragraph. 592 | (push "" result) 593 | (incf lines-consumed)) 594 | ((and offset (= indentation this-offset)) 595 | ;; start of new item, or continuation of previous item 596 | (if (and result (search "@item" (car result) :test #'char=)) 597 | (push (format nil "@itemx ~A" (texinfo-line line)) 598 | result) 599 | (progn 600 | (push "" result) 601 | (push (format nil "@item ~A" (texinfo-line line)) 602 | result))) 603 | (incf lines-consumed)) 604 | ((> indentation this-offset) 605 | ;; continued item from previous line 606 | (push (texinfo-line line) result) 607 | (incf lines-consumed)) 608 | (t 609 | ;; end of itemization 610 | (loop-finish)))) 611 | ;; a single-line table isn't. 612 | (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) 613 | (values lines-consumed 614 | `("" "@table @emph" ,@(reverse result) "@end table" "")) 615 | nil))) 616 | 617 | ;;; section markup 618 | 619 | (defmacro with-maybe-section (index &rest forms) 620 | `(multiple-value-bind (count collected) (progn ,@forms) 621 | (when count 622 | (dolist (line collected) 623 | (write-line line *texinfo-output*)) 624 | (incf ,index (1- count))))) 625 | 626 | (defun write-texinfo-string (string &optional lambda-list) 627 | "Try to guess as much formatting for a raw docstring as possible." 628 | (let ((*texinfo-variables* (flatten lambda-list)) 629 | (lines (string-lines (escape-for-texinfo string nil)))) 630 | (loop for line-number from 0 below (length lines) 631 | for line = (svref lines line-number) 632 | do (cond 633 | ((with-maybe-section line-number 634 | (and (lisp-section-p line line-number lines) 635 | (collect-lisp-section lines line-number)))) 636 | ((with-maybe-section line-number 637 | (and (maybe-itemize-offset line) 638 | (collect-maybe-itemized-section lines line-number)))) 639 | ((with-maybe-section line-number 640 | (and (maybe-table-offset line-number lines) 641 | (collect-maybe-table-section lines line-number)))) 642 | (t 643 | (write-line (texinfo-line line) *texinfo-output*)))))) 644 | 645 | ;;;; texinfo formatting tools 646 | 647 | (defun hide-superclass-p (class-name super-name) 648 | (let ((super-package (symbol-package super-name))) 649 | (or 650 | ;; KLUDGE: We assume that we don't want to advertise internal 651 | ;; classes in CP-lists, unless the symbol we're documenting is 652 | ;; internal as well. 653 | (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) 654 | (not (eq super-package (symbol-package class-name)))) 655 | ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or 656 | ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them 657 | ;; simply as a matter of convenience. The assumption here is that 658 | ;; the inheritance is incidental unless the name of the condition 659 | ;; begins with SIMPLE-. 660 | (and (member super-name '(simple-error simple-condition)) 661 | (let ((prefix "SIMPLE-")) 662 | (mismatch prefix (string class-name) :end2 (length prefix))) 663 | t ; don't return number from MISMATCH 664 | )))) 665 | 666 | (defun hide-slot-p (symbol slot) 667 | ;; FIXME: There is no pricipal reason to avoid the slot docs fo 668 | ;; structures and conditions, but their DOCUMENTATION T doesn't 669 | ;; currently work with them the way we'd like. 670 | (not (and (typep (find-class symbol nil) 'standard-class) 671 | (docstring slot t)))) 672 | 673 | (defun texinfo-anchor (doc) 674 | (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) 675 | 676 | ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" 677 | (defun texinfo-begin (doc &aux *print-pretty*) 678 | (let ((kind (get-kind doc))) 679 | (format *texinfo-output* "@~A {~:(~A~)} ~(~A~@[ ~{~A~^ ~}~]~)~%" 680 | (case kind 681 | ((package constant variable) 682 | "defvr") 683 | ((structure class condition type) 684 | "deftp") 685 | (t 686 | "deffn")) 687 | (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) 688 | (title-name doc) 689 | (lambda-list doc)))) 690 | 691 | (defun texinfo-index (doc) 692 | (let ((title (title-name doc))) 693 | (case (get-kind doc) 694 | ((structure type class condition) 695 | (format *texinfo-output* "@tindex ~A~%" title)) 696 | ((variable constant) 697 | (format *texinfo-output* "@vindex ~A~%" title)) 698 | ((compiler-macro function method-combination macro generic-function) 699 | (format *texinfo-output* "@findex ~A~%" title))))) 700 | 701 | (defun texinfo-inferred-body (doc) 702 | (when (member (get-kind doc) '(class structure condition)) 703 | (let ((name (get-name doc))) 704 | ;; class precedence list 705 | (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%" 706 | (remove-if (lambda (class) (hide-superclass-p name class)) 707 | (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) 708 | ;; slots 709 | (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) 710 | (class-direct-slots (find-class name))))) 711 | (when slots 712 | (format *texinfo-output* "Slots:~%@itemize~%") 713 | (dolist (slot slots) 714 | (format *texinfo-output* 715 | "@item ~(@code{~A}~#[~:; --- ~]~ 716 | ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" 717 | (slot-definition-name slot) 718 | (remove 719 | nil 720 | (mapcar 721 | (lambda (name things) 722 | (if things 723 | (list name (length things) things))) 724 | '("initarg" "reader" "writer") 725 | (list 726 | (slot-definition-initargs slot) 727 | (slot-definition-readers slot) 728 | (slot-definition-writers slot))))) 729 | ;; FIXME: Would be neater to handler as children 730 | (write-texinfo-string (docstring slot t))) 731 | (format *texinfo-output* "@end itemize~%~%")))))) 732 | 733 | (defun texinfo-body (doc) 734 | (write-texinfo-string (get-string doc))) 735 | 736 | (defun texinfo-end (doc) 737 | (write-line (case (get-kind doc) 738 | ((package variable constant) "@end defvr") 739 | ((structure type class condition) "@end deftp") 740 | (t "@end deffn")) 741 | *texinfo-output*)) 742 | 743 | (defun write-texinfo (doc) 744 | "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." 745 | (texinfo-anchor doc) 746 | (texinfo-begin doc) 747 | (texinfo-index doc) 748 | (texinfo-inferred-body doc) 749 | (texinfo-body doc) 750 | (texinfo-end doc) 751 | ;; FIXME: Children should be sorted one way or another 752 | (mapc #'write-texinfo (get-children doc))) 753 | 754 | ;;;; main logic 755 | 756 | (defun collect-gf-documentation (gf) 757 | "Collects method documentation for the generic function GF" 758 | (loop for method in (generic-function-methods gf) 759 | for doc = (maybe-documentation method t) 760 | when doc 761 | collect doc)) 762 | 763 | (defun collect-name-documentation (name) 764 | (loop for type in *documentation-types* 765 | for doc = (maybe-documentation name type) 766 | when doc 767 | collect doc)) 768 | 769 | (defun collect-symbol-documentation (symbol) 770 | "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of 771 | the form DOC instances. See `*documentation-types*' for the possible 772 | values of doc-type." 773 | (nconc (collect-name-documentation symbol) 774 | (collect-name-documentation (list 'setf symbol)))) 775 | 776 | (defun collect-documentation (package) 777 | "Collects all documentation for all external symbols of the given 778 | package, as well as for the package itself." 779 | (let* ((*documentation-package* (find-package package)) 780 | (docs nil)) 781 | (check-type package package) 782 | (do-external-symbols (symbol package) 783 | (setf docs (nconc (collect-symbol-documentation symbol) docs))) 784 | (let ((doc (maybe-documentation *documentation-package* t))) 785 | (when doc 786 | (push doc docs))) 787 | docs)) 788 | 789 | (defmacro with-texinfo-file (pathname &body forms) 790 | `(with-open-file (*texinfo-output* ,pathname 791 | :direction :output 792 | :if-does-not-exist :create 793 | :if-exists :supersede) 794 | ,@forms)) 795 | 796 | (defun generate-includes (directory &rest packages) 797 | "Create files in `directory' containing Texinfo markup of all 798 | docstrings of each exported symbol in `packages'. `directory' is 799 | created if necessary. If you supply a namestring that doesn't end in a 800 | slash, you lose. The generated files are of the form 801 | \"__.texinfo\" and can be included 802 | via @include statements. Texinfo syntax-significant characters are 803 | escaped in symbol names, but if a docstring contains invalid Texinfo 804 | markup, you lose." 805 | (handler-bind ((warning #'muffle-warning)) 806 | (let ((directory (merge-pathnames (pathname directory)))) 807 | (ensure-directories-exist directory) 808 | (dolist (package packages) 809 | (dolist (doc (collect-documentation (find-package package))) 810 | (with-texinfo-file (merge-pathnames (include-pathname doc) directory) 811 | (write-texinfo doc)))) 812 | directory))) 813 | 814 | (defun document-package (package &optional filename) 815 | "Create a file containing all available documentation for the 816 | exported symbols of `package' in Texinfo format. If `filename' is not 817 | supplied, a file \".texinfo\" is generated. 818 | 819 | The definitions can be referenced using Texinfo statements like 820 | @ref{__.texinfo}. Texinfo 821 | syntax-significant characters are escaped in symbol names, but if a 822 | docstring contains invalid Texinfo markup, you lose." 823 | (handler-bind ((warning #'muffle-warning)) 824 | (let* ((package (find-package package)) 825 | (filename (or filename (make-pathname 826 | :name (string-downcase (package-name package)) 827 | :type "texinfo"))) 828 | (docs (sort (collect-documentation package) #'documentation<))) 829 | (with-texinfo-file filename 830 | (dolist (doc docs) 831 | (write-texinfo doc))) 832 | filename))) 833 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-current-year.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function current-year} 2 | @deffn {Function} current-year 3 | @findex current-year 4 | Return the current year as a @code{fixnum}. 5 | @end deffn 6 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-day-of-week.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function day-of-week} 2 | @deffn {Function} day-of-week fixed-time 3 | @findex day-of-week 4 | Return the day of the week associated with a given @code{fixed-time}. 5 | The result is a @code{fixnum} with 0 representing Sunday, through 6 on Saturday. 6 | @end deffn 7 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-days-in-month.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function days-in-month} 2 | @deffn {Function} days-in-month month &optional year 3 | @findex days-in-month 4 | Returns the number of days in the given month of the specified year. 5 | @end deffn 6 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-falls-on-weekend-p.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function falls-on-weekend-p} 2 | @deffn {Function} falls-on-weekend-p fixed-time 3 | @findex falls-on-weekend-p 4 | Return @code{t} if the given @code{fixed-time} occurs on a Saturday or Sunday. 5 | @end deffn 6 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-find-smallest-resolution.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function find-smallest-resolution} 2 | @deffn {Function} find-smallest-resolution step-by 3 | @findex find-smallest-resolution 4 | Examine the property list @code{step-by} and return the smallest unit of time 5 | specified. 6 | 7 | For example, given the following property list: 8 | 9 | @lisp 10 | (:DAY 10 :HOUR 5 :MINUTE 2) 11 | @end lisp 12 | 13 | The result is @code{:minute}. 14 | @end deffn 15 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-fixed-time.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function fixed-time} 2 | @deffn {Function} fixed-time &rest args 3 | @findex fixed-time 4 | Return a fixed point in time relative to the time of the call. @code{args} is a 5 | property list giving a specific precision for the return value. 6 | 7 | If the keyword argument @code{:now} is given, all else is ignored; this is 8 | equivalent to calling @code{local-time:now}. 9 | 10 | Otherwise, any keyword arguments given override their corresponding elements 11 | in the current time. Further, any elements smaller in resolution than the 12 | finest specified element are reduced to 0 or 1, according to their position. 13 | 14 | For example, assuming the current time is "@@2007-11-17T23:02:00.000", 15 | compare these outputs: 16 | 17 | @lisp 18 | (fixed-time :month 4) ⇒ @@2007-04-01T00:00:00.000 19 | (fixed-time :day 10) ⇒ @@2007-11-10T00:00:00.000 20 | (fixed-time :hour 15) ⇒ @@2007-11-17T15:00:00.000 21 | @end lisp 22 | 23 | This behavior makes it very easy to return a fixed time for "april of this 24 | year", etc. If you wish to determine the date of the previous April, while 25 | preserving the current day of the month, hour of the day, etc., then see the 26 | function @code{previous-time}. 27 | @end deffn 28 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-floor-time.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function floor-time} 2 | @deffn {Function} floor-time fixed-time &optional resolution 3 | @findex floor-time 4 | Reduce a fixed time to be no finer than @code{resolution}. 5 | 6 | For example, if the date is 2007-04-20, and the resolution is :month, the 7 | date is floored to 2007-04-01. Anything smaller than the resolution is 8 | reduced to zero (or 1, if it is a day or month being reduced). 9 | @end deffn 10 | -------------------------------------------------------------------------------- /doc/docstrings/fun-periods-leapp.texinfo: -------------------------------------------------------------------------------- 1 | @anchor{Function leapp} 2 | @deffn {Function} leapp year 3 | @findex leapp 4 | Return @code{t} if @code{year} falls on a leap year. 5 | @end deffn 6 | -------------------------------------------------------------------------------- /doc/make-tempfiles.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Create Texinfo snippets from the documentation of exported symbols. 4 | 5 | SBCL="$SBCLRUNTIME --noinform --noprint --disable-debugger" 6 | SBCL="$SBCL --load /Users/johnw/Library/Lisp/init.lisp" 7 | SBCL="$SBCL --load /Users/johnw/Library/Lisp/bootstrap.lisp" 8 | 9 | # Output directory. This has to end with a slash (it's interpreted by Lisp's 10 | # `pathname' function) or you lose. This is normally set from Makefile. 11 | DOCSTRINGDIR="${DOCSTRINGDIR:-docstrings/}" 12 | 13 | $SBCL < number 40) :year :day) 180 | number))))) 181 | (if-let ((first (p/number in eof-error-p))) 182 | (if-let ((ch (peek-char nil in nil))) 183 | (if (char= #\/ ch) 184 | (progn 185 | (read-char in) 186 | (let ((second (p/number in eof-error-p))) 187 | (if second 188 | (let ((ch (peek-char nil in nil))) 189 | (if (and ch (char= #\/ ch)) 190 | (progn 191 | (read-char in) 192 | (let ((third (p/number in eof-error-p))) 193 | (if third 194 | (list :fixed 195 | :year first 196 | :month second 197 | :day third) 198 | (error "Failed to read literal date string")))) 199 | (list :fixed :year first :month second))) 200 | (error "Failed to read literal date string")))) 201 | (unread-token in first)))))))))) 202 | 203 | ;;;_ * A duration of time 204 | 205 | (defun p/time-duration (in &optional (eof-error-p t)) 206 | (if-let ((duration (p/duration-spec in eof-error-p))) 207 | ;; jww (2007-11-28): I don't support "3 months, 2 weeks" yet 208 | (loop while (eq 'and (peek-token in nil)) do 209 | (read-token in) 210 | (nconc duration (p/duration-spec in eof-error-p))) 211 | (cons :duration duration))) 212 | 213 | (defun p/duration-spec (in &optional (eof-error-p t)) 214 | (let ((number (p/cardinal in eof-error-p))) 215 | (if number 216 | (let ((unit (p/time-unit in eof-error-p))) 217 | (if unit 218 | (list unit number) 219 | (unread-token in number))) 220 | (progn 221 | (if (eq 'a (peek-token in eof-error-p)) 222 | (read-token in)) 223 | (if-let ((unit (p/time-unit in eof-error-p))) 224 | (list unit 1)))))) 225 | 226 | ;;;_ * A relative point in time 227 | 228 | (defun make-duration-relative (data) 229 | (let (new-list) 230 | (loop for arg in (rest data) do 231 | (when (keywordp arg) 232 | (ecase arg 233 | (:year 234 | (push :month new-list) 235 | (push 1 new-list)) 236 | (:month 237 | (push :day new-list) 238 | (push 1 new-list)) 239 | (:week 240 | (push :day-of-week new-list) 241 | (push 0 new-list)) 242 | (:day 243 | (push :hour new-list) 244 | (push 0 new-list)) 245 | (:hour 246 | (push :minute new-list) 247 | (push 0 new-list)) 248 | (:minute 249 | (push :second new-list) 250 | (push 0 new-list)) 251 | (:second 252 | (push :millisecond new-list) 253 | (push 0 new-list)) 254 | (:millisecond 255 | (push :microsecond new-list) 256 | (push 0 new-list)) 257 | (:microsecond 258 | (push :nanosecond new-list) 259 | (push 0 new-list))))) 260 | (cons :rel (nreverse new-list)))) 261 | 262 | (defun p/relative-time (in &optional (eof-error-p t)) 263 | (let ((token (read-token in eof-error-p))) 264 | (case token 265 | (the (list :rel :next (p/time-reference in))) 266 | 267 | (this 268 | (let ((reference (p/time-reference in))) 269 | (if (eq :duration (car reference)) 270 | (list reference 271 | (list :rel :from 272 | (list :rel :this 273 | (make-duration-relative reference)))) 274 | (list :rel :this reference)))) 275 | 276 | ((next following) 277 | (let ((reference (p/time-reference in))) 278 | (if (eq :duration (car reference)) 279 | (list reference 280 | (list :rel :from 281 | (list :rel :next 282 | (make-duration-relative reference)))) 283 | (list :rel :next reference)))) 284 | 285 | ((last previous preceeding) 286 | (let ((reference (p/time-reference in))) 287 | (if (eq :duration (car reference)) 288 | (list reference 289 | (list :rel :from 290 | (list :rel :last 291 | (make-duration-relative reference)))) 292 | (list :rel :last reference)))) 293 | 294 | ;;; (((? the p/ws) p/ordinal p/ws p/time-reference (? #\s)) 295 | ;;; (list p/ordinal (if (eq :duration (car p/time-reference)) 296 | ;;; (cons :rel (rest p/time-reference)) 297 | ;;; p/time-reference))) 298 | 299 | ((before prior) 300 | (list :rel :before (p/time-reference in))) 301 | 302 | (after 303 | (list :rel :after (p/time-reference in))) 304 | 305 | ((beginning ;; (the p/ws beginning p/ws of) 306 | ) 307 | (list :rel :begin (p/time-reference in))) 308 | 309 | (( ;; (the p/ws beginning p/ws of) 310 | starting 311 | ;; (the p/ws start p/ws of) 312 | from 313 | since) 314 | (list :rel :from (p/time-reference in))) 315 | 316 | ((in during) 317 | (list :rel :in (p/time-reference in))) 318 | 319 | ((/ ;; (the p/ws end p/ws of) 320 | stopping 321 | finishing 322 | to 323 | until) 324 | (list :rel :to (p/time-reference in))) 325 | 326 | (of 327 | (list :rel :of (p/time-reference in))) 328 | 329 | ((ending 330 | ;; (the p/ws end p/ws of) 331 | ) 332 | (list :rel :end (p/time-reference in))) 333 | 334 | (otherwise 335 | (unread-token in token))))) 336 | 337 | (defun p/time-reference (in &optional (eof-error-p t)) 338 | (or (p/fixed-time in eof-error-p) 339 | (p/days-of-week in eof-error-p) 340 | (p/period-unit in eof-error-p) 341 | (p/time-duration in eof-error-p) 342 | (p/relative-time in eof-error-p))) 343 | 344 | (defun p/qualified-time (in &optional (eof-error-p t)) 345 | (let ((everyp (eq (peek-token in eof-error-p) 'every)) 346 | result) 347 | (if-let ((time (p/time-reference in eof-error-p))) 348 | (setf result (if everyp (progn 349 | (read-token in) 350 | (list :every time)) 351 | time)) 352 | (loop for time = (p/time-reference in nil) while time do 353 | (setf result (list result time)))) 354 | result)) 355 | 356 | (defun p/time (in &optional (eof-error-p t)) 357 | (let ((*token-stack* nil)) 358 | (if-let ((time (p/qualified-time in eof-error-p))) 359 | (if (eq (peek-token in nil) 'ago) 360 | (progn 361 | (read-token in) 362 | (list :ago time)) 363 | time)))) 364 | 365 | ;;;_ * A recurring period of time 366 | 367 | (defun compile-duration (data) 368 | (let (new-list) 369 | (do ((old data (cdr old))) 370 | ((null old)) 371 | (if (keywordp (first old)) 372 | (ecase (first old) 373 | (:year (push :years new-list)) 374 | (:month (push :months new-list)) 375 | (:week 376 | (push :days new-list) 377 | (push (* 7 (first (rest old))) new-list) 378 | (setf old (rest old))) 379 | (:day (push :days new-list)) 380 | (:hour (push :hours new-list)) 381 | (:minute (push :minutes new-list)) 382 | (:second (push :seconds new-list)) 383 | (:millisecond (push :milliseconds new-list)) 384 | (:microsecond (push :microseconds new-list)) 385 | (:nanosecond (push :nanoseconds new-list))) 386 | (progn 387 | (assert (integerp (first old))) 388 | (push (first old) new-list)))) 389 | (lambda (anchor) 390 | (time-range :duration (apply #'duration (nreverse new-list)) 391 | :anchor anchor)))) 392 | 393 | (defun compile-relative-time (data) 394 | (case (first data) 395 | (:this (compile-time (cadr data))) 396 | (:last 397 | (let ((reference (compile-time (cadr data)))) 398 | ;; What about the difference between these: 399 | ;; the last two months 400 | ;; the last month 401 | ;; last month 402 | ;; jww (2007-11-27): At the moment, all three forms present as having a 403 | ;; duration next on the list, which is not correct. The last one 404 | ;; should be a relative time unit. 405 | (lambda (anchor) 406 | (let ((range (funcall reference anchor))) 407 | (if (get-range-begin range) 408 | (time-range-previous range) 409 | (time-range :begin )))))) 410 | 411 | (:next 412 | (let ((reference (compile-time (cadr data)))) 413 | (lambda (anchor) 414 | (time-range-next (funcall reference anchor))))) 415 | 416 | ;; jww (2007-12-02): is there a distinction here? 417 | ((:to :before) 418 | (let ((reference (compile-time (cadr data)))) 419 | (lambda (anchor) 420 | (time-range :end (time-range-begin 421 | (funcall reference anchor)) 422 | :anchor anchor)))) 423 | 424 | (:from 425 | (let ((reference (compile-time (cadr data)))) 426 | (lambda (anchor) 427 | (time-range :begin (time-range-begin 428 | (funcall reference anchor)) 429 | :anchor anchor)))) 430 | (:after 431 | (let ((reference (compile-time (cadr data)))) 432 | (lambda (anchor) 433 | (time-range :begin (time-range-end 434 | (funcall reference anchor)) 435 | :anchor anchor)))) 436 | 437 | (otherwise 438 | (let* ((reltime (apply #'relative-time data)) 439 | (smallest-resolution (find-smallest-resolution data)) 440 | (duration (compile-duration (list smallest-resolution 1)))) 441 | (lambda (anchor) 442 | (time-range :begin reltime 443 | :duration (time-range-duration 444 | (funcall duration anchor)) 445 | :anchor anchor)))))) 446 | 447 | (defun compile-time (data) 448 | (if (keywordp (first data)) 449 | (case (first data) 450 | (:fixed 451 | (let* ((moment (apply #'fixed-time (rest data))) 452 | (smallest-resolution (find-smallest-resolution (rest data))) 453 | (duration (compile-duration (list smallest-resolution 1)))) 454 | (lambda (anchor) 455 | (time-range :begin moment 456 | :duration (time-range-duration 457 | (funcall duration anchor)))))) 458 | (:duration 459 | (let ((duration (compile-duration (rest data)))) 460 | (lambda (anchor) 461 | (time-range :begin anchor 462 | :duration (time-range-duration 463 | (funcall duration anchor)))))) 464 | (:rel (compile-relative-time (rest data))) 465 | (:every 466 | ;; jww (2007-11-26): Create a time period object here -- or must that 467 | ;; be one step removed from this function? 468 | (assert "Compiling of period expressions not yet supported"))) 469 | 470 | (let (result) 471 | (dolist (element data) 472 | (let ((function (compile-time element))) 473 | (setf result 474 | (if result 475 | (let ((previous result)) 476 | (lambda (anchor) 477 | (let ((range (funcall function anchor))) 478 | (funcall previous (time-range-begin range))))) 479 | function)))) 480 | (or result #'identity)))) 481 | 482 | (defun parse-time-period (string) 483 | (funcall (compile-time (p/time (make-string-input-stream string))) 484 | (fixed-time :hour 0))) 485 | 486 | (defun parse-time-range (string) 487 | ;; jww (2007-12-01): The call to fixed-time here should be sensitive to the 488 | ;; input precision 489 | (funcall (compile-time (p/time (make-string-input-stream string))) 490 | (fixed-time :hour 0))) 491 | 492 | (defun time-parser-tests () 493 | (dolist 494 | (expr '("this year" 495 | "next year" 496 | "last year" 497 | "the year before last" 498 | "jan 8" 499 | "jan 2008" 500 | "2008/01/01" 501 | "2 months" 502 | "2 months since jan 8" 503 | "january of last year" 504 | "three months ago" 505 | "1 months, 2 days ago" 506 | "every friday starting tomorrow" 507 | "every day this week" 508 | "every day of this week" 509 | "every ten days" 510 | "the day after tuesday" 511 | "monthly" 512 | "monthly from the beginning of this year" 513 | "monthly from now until the end of the year" 514 | "the last week of last year" 515 | ;; "every weekend this year" 516 | )) 517 | (format t "EXPR < ~A~% >= ~S~%" expr 518 | (p/time (make-string-input-stream expr))))) 519 | 520 | ;; EOF 521 | -------------------------------------------------------------------------------- /periods-series.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | 3 | ;; Copyright (c) 2007, John Wiegley. All rights reserved. 4 | ;; 5 | ;; Redistribution and use in source and binary forms, with or without 6 | ;; modification, are permitted provided that the following conditions are 7 | ;; met: 8 | ;; 9 | ;; - Redistributions of source code must retain the above copyright 10 | ;; notice, this list of conditions and the following disclaimer. 11 | ;; 12 | ;; - Redistributions in binary form must reproduce the above copyright 13 | ;; notice, this list of conditions and the following disclaimer in the 14 | ;; documentation and/or other materials provided with the distribution. 15 | ;; 16 | ;; - Neither the name of New Artisans LLC nor the names of its 17 | ;; contributors may be used to endorse or promote products derived from 18 | ;; this software without specific prior written permission. 19 | ;; 20 | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | (asdf:defsystem :periods-series 33 | :serial t 34 | :description "Extension of PERIODS providing SERIES-compatible functions." 35 | :author "Johh Wiegley " 36 | :maintainer "Christophe Junke " 37 | :license "BSD-3" 38 | :version "0.0.1" 39 | :depends-on (:periods :series) 40 | :components ((:file "periods-series"))) 41 | -------------------------------------------------------------------------------- /periods-series.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :periods-series 4 | (:use :common-lisp :periods :series) 5 | ;; This symbol is not external in :periods package 6 | (:import-from #:periods 7 | #:time-generator) 8 | (:export scan-times 9 | scan-relative-times 10 | scan-time-period 11 | collate-by-time-period)) 12 | 13 | (in-package :periods-series) 14 | 15 | (defmacro scan-times (start duration &key (reverse nil)) 16 | "This macro represents continguous time durations as a SERIES. 17 | 18 | Example: 19 | 20 | (subseries (scan-times @2007-11-01 (duration :months 1)) 0 10) 21 | 22 | `UNTIL-IF' can be used to bound the end of the range by a date: 23 | 24 | (collect (until-if #'(lambda (time) 25 | (local-time:timestamp>= time @2009-01-01)) 26 | (scan-times @2007-11-01 (duration :months 1))))" 27 | `(map-fn 'fixed-time (time-generator ,start ,duration :reverse ,reverse))) 28 | 29 | (defmacro scan-relative-times (anchor relative-time &key (reverse nil)) 30 | `(scan-fn 'fixed-time (relative-time-generator ,anchor ,relative-time 31 | :reverse ,reverse))) 32 | 33 | (defun scan-time-period (period) 34 | (multiple-value-call #'until-if 35 | #'null (map-fn '(values 36 | (or fixed-time null) 37 | (or fixed-time null) 38 | (or fixed-time null)) 39 | (time-period-generator period)))) 40 | 41 | (defun collate-by-time-period (item-series period &key (key #'identity)) 42 | "Return two series, one is a series of lists grouped by ranges within the 43 | period, and the other is a series of ranges, each element of which corresponds 44 | to the group elements in the same position within the first series." 45 | (multiple-value-call #'map-fn 46 | '(values fixed-time fixed-time series) 47 | (let (next-series) 48 | #'(lambda (begin end next-begin) 49 | (declare (ignore next-begin)) 50 | (values begin end 51 | (let (matching) 52 | (multiple-value-setq (matching next-series) 53 | (split-if (or next-series item-series) 54 | #'(lambda (item) 55 | (periods::time-within-begin-end-p 56 | (funcall key item) begin end)))) 57 | matching)))) 58 | (scan-time-period period))) 59 | -------------------------------------------------------------------------------- /periods.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | 3 | ;; Copyright (c) 2007, John Wiegley. All rights reserved. 4 | ;; 5 | ;; Redistribution and use in source and binary forms, with or without 6 | ;; modification, are permitted provided that the following conditions are 7 | ;; met: 8 | ;; 9 | ;; - Redistributions of source code must retain the above copyright 10 | ;; notice, this list of conditions and the following disclaimer. 11 | ;; 12 | ;; - Redistributions in binary form must reproduce the above copyright 13 | ;; notice, this list of conditions and the following disclaimer in the 14 | ;; documentation and/or other materials provided with the distribution. 15 | ;; 16 | ;; - Neither the name of New Artisans LLC nor the names of its 17 | ;; contributors may be used to endorse or promote products derived from 18 | ;; this software without specific prior written permission. 19 | ;; 20 | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | (cl:in-package :asdf-user) 33 | 34 | (asdf:defsystem :periods 35 | :serial t 36 | :description "Utilities for manipulating time ranges and distances, based on LOCAL-TIME." 37 | :author "Johh Wiegley " 38 | :maintainer "Christophe Junke " 39 | :license "BSD-3" 40 | :version "0.0.2" 41 | :depends-on (:local-time) 42 | :components ((:file "periods") 43 | (:file "strptime") 44 | (:file "parser"))) 45 | -------------------------------------------------------------------------------- /periods.lisp: -------------------------------------------------------------------------------- 1 | ;;; periods --- A library for working with periods of time 2 | 3 | ;; Copyright (C) 2007 John Wiegley. All rights reserved. 4 | 5 | ;; Author: John Wiegley 6 | ;; Created: 29 Oct 2007 7 | ;; Modified: 17 Nov 2007 8 | ;; Version: 0.2 9 | ;; Keywords: lisp programming development 10 | ;; X-URL: http://www.newartisans.com/ 11 | 12 | ;; Redistribution and use in source and binary forms, with or without 13 | ;; modification, are permitted provided that the following conditions are 14 | ;; met: 15 | ;; 16 | ;; - Redistributions of source code must retain the above copyright 17 | ;; notice, this list of conditions and the following disclaimer. 18 | ;; 19 | ;; - Redistributions in binary form must reproduce the above copyright 20 | ;; notice, this list of conditions and the following disclaimer in the 21 | ;; documentation and/or other materials provided with the distribution. 22 | ;; 23 | ;; - Neither the name of New Artisans LLC nor the names of its 24 | ;; contributors may be used to endorse or promote products derived from 25 | ;; this software without specific prior written permission. 26 | ;; 27 | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 28 | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 29 | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 30 | ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 31 | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 32 | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 33 | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 34 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 35 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 36 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 37 | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 38 | 39 | ;;; Commentary: 40 | 41 | ;; The PERIODS library is fully described in the PDF documentation which 42 | ;; accompanies this source code. Please refer there for complete details. 43 | 44 | (declaim (optimize (debug 3) (safety 3) (speed 1) (space 0))) 45 | 46 | (defpackage :periods 47 | (:use :common-lisp :local-time) 48 | (:nicknames :time-periods) 49 | (:export leapp 50 | increment-time 51 | decrement-time 52 | floor-time 53 | parse-time-period 54 | parse-time-range 55 | time-period-generator 56 | time-periods 57 | time-period 58 | time-range 59 | time-range-begin 60 | time-range-end 61 | time-range-duration 62 | time-within-range-p 63 | 64 | with-timestamp-range 65 | update-range 66 | 67 | map-over-time 68 | do-over-time 69 | collate-by-time-period 70 | sleep-until 71 | day-of-week 72 | time-difference 73 | duration-seconds 74 | falls-on-weekend-p 75 | current-year 76 | find-smallest-resolution 77 | duration 78 | add-duration 79 | add-time 80 | subtract-duration 81 | subtract-time 82 | 83 | *input-time-format* 84 | *output-time-format* 85 | 86 | fixed-time 87 | read-fixed-time 88 | strptime 89 | strptime-decoded 90 | strftime) 91 | (:shadow day-of 92 | days-in-month)) 93 | 94 | (in-package :periods) 95 | 96 | ;;;_ * Global variables 97 | 98 | (defvar *input-time-format* "%Y/%m/%d%| %H:%M:%S") 99 | (defvar *output-time-format* *input-time-format*) 100 | 101 | ;;;_ * Basic utility functions 102 | 103 | (defparameter *days-in-months* #(31 28 31 30 31 30 31 31 30 31 30 31)) 104 | 105 | ;; Snippet courtesy of Xach on #lisp 106 | (declaim (inline leapp)) 107 | (defun leapp (year) 108 | "Return T if YEAR falls on a leap year." 109 | (cond ((zerop (mod year 400)) t) 110 | ((zerop (mod year 100)) nil) 111 | ((zerop (mod year 4)) t) 112 | (t nil))) 113 | 114 | (declaim (inline current-year)) 115 | (defun current-year () 116 | "Return the current year as a FIXNUM." 117 | (nth-value 5 (get-decoded-time))) 118 | 119 | (defun days-in-month (month &optional year) 120 | (let ((days (aref *days-in-months* (1- month))) 121 | (the-year (or year (current-year)))) 122 | (if (and (= month 2) 123 | (leapp the-year)) 124 | (incf days) 125 | days))) 126 | 127 | (declaim (inline nanosecond-part microsecond-part millisecond-part)) 128 | 129 | (defun nanosecond-part (bignum) 130 | (nth-value 1 (floor bignum 1000))) 131 | (defun microsecond-part (bignum) 132 | (nth-value 1 (floor (floor bignum 1000) 1000))) 133 | (defun millisecond-part (bignum) 134 | (nth-value 0 (floor bignum 1000000))) 135 | 136 | (declaim (inline set-nanosecond-part set-microsecond-part 137 | set-millisecond-part)) 138 | 139 | (defun set-nanosecond-part (bignum nsecs) 140 | (+ (* (floor bignum 1000) 1000) nsecs)) 141 | (defun set-microsecond-part (bignum usecs) 142 | (+ (* (floor bignum 1000000) 1000000) 143 | (* usecs 1000) 144 | (nth-value 1 (floor bignum 1000)))) 145 | (defun set-millisecond-part (bignum msecs) 146 | (+ (* msecs 1000000) 147 | (nth-value 1 (floor bignum 1000000)))) 148 | 149 | (defun floor-time (fixed-time &optional resolution) 150 | "Reduce a fixed time to be no finer than RESOLUTION. 151 | 152 | For example, if the date is 2007-04-20, and the resolution is :month, the 153 | date is floored to 2007-04-01. Anything smaller than the resolution is 154 | reduced to zero (or 1, if it is a day or month being reduced)." 155 | (declare (type timestamp fixed-time)) 156 | (multiple-value-bind 157 | (nsec ss mm hh day month year) 158 | (decode-timestamp fixed-time) 159 | (block nil 160 | (if (eq resolution :nanosecond) (return)) 161 | (setf nsec (set-nanosecond-part nsec 0)) 162 | (if (eq resolution :microsecond) (return)) 163 | (setf nsec (set-microsecond-part nsec 0)) 164 | (if (eq resolution :millisecond) (return)) 165 | (setf nsec (set-millisecond-part nsec 0)) 166 | (if (eq resolution :second) (return)) 167 | (setf ss 0) 168 | (if (eq resolution :minute) (return)) 169 | (setf mm 0) 170 | (if (eq resolution :hour) (return)) 171 | (setf hh 0) 172 | (if (or (eq resolution :day) 173 | (eq resolution :day-of-week)) (return)) 174 | (setf day 1) 175 | (if (eq resolution :month) (return)) 176 | (setf month 1)) 177 | (encode-timestamp nsec ss mm hh day month year))) 178 | 179 | (defun find-smallest-resolution (step-by) 180 | "Examine the property list STEP-BY and return the smallest unit of time 181 | specified. 182 | 183 | For example, given the following property list: 184 | 185 | (:DAY 10 :HOUR 5 :MINUTE 2) 186 | 187 | The result is :MINUTE." 188 | (cond 189 | ((member :nanosecond step-by) :nanosecond) 190 | ((member :microsecond step-by) :microsecond) 191 | ((member :millisecond step-by) :millisecond) 192 | ((member :second step-by) :second) 193 | ((member :minute step-by) :minute) 194 | ((member :hour step-by) :hour) 195 | ((member :day step-by) :day) 196 | ((member :day-of-week step-by) :day-of-week) 197 | ((member :month step-by) :month) 198 | (t (error "Could not find a time resolution in ~S" step-by)))) 199 | 200 | ;;;_ * FIXED-TIME 201 | 202 | (deftype fixed-time () 203 | 'local-time:timestamp) 204 | 205 | (defun fixed-time (&rest args) 206 | "Return a fixed point in time relative to the time of the call. ARGS is a 207 | property list giving a specific precision for the return value. 208 | 209 | If the keyword argument :NOW is given, all else is ignored; this is 210 | equivalent to calling LOCAL-TIME:NOW. 211 | 212 | Otherwise, any keyword arguments given override their corresponding elements 213 | in the current time. Further, any elements smaller in resolution than the 214 | finest specified element are reduced to 0 or 1, according to their position. 215 | 216 | For example, assuming the current time is \"@2007-11-17T23:02:00.000\", 217 | compare these outputs: 218 | 219 | (fixed-time :month 4) => @2007-04-01T00:00:00.000 220 | (fixed-time :day 10) => @2007-11-10T00:00:00.000 221 | (fixed-time :hour 15) => @2007-11-17T15:00:00.000 222 | 223 | This behavior makes it very easy to return a fixed time for \"april of this 224 | year\", etc. If you wish to determine the date of the previous April, while 225 | preserving the current day of the month, hour of the day, etc., then see the 226 | function PREVIOUS-TIME." 227 | (if (member :now args) 228 | (local-time:now) 229 | (multiple-value-bind 230 | (nsec ss mm hh day month year) 231 | (decode-timestamp (local-time:now)) 232 | (block nil 233 | (let ((this-nsec (getf args :nanosecond)) 234 | (this-usec (getf args :microsecond)) 235 | (this-ms (getf args :millisecond)) 236 | (this-ss (getf args :second)) 237 | (this-mm (getf args :minute)) 238 | (this-hh (getf args :hour)) 239 | (this-day (getf args :day)) 240 | (this-month (getf args :month)) 241 | (this-year (getf args :year)) 242 | (truncate t)) 243 | (if this-nsec 244 | (setf nsec (set-nanosecond-part nsec this-nsec) 245 | truncate nil) 246 | (if truncate (setf nsec (set-nanosecond-part nsec 0)))) 247 | (if this-usec 248 | (setf nsec (set-microsecond-part nsec this-usec) 249 | truncate nil) 250 | (if truncate (setf nsec (set-microsecond-part nsec 0)))) 251 | (if this-ms 252 | (setf nsec (set-millisecond-part nsec this-ms) 253 | truncate nil) 254 | (if truncate (setf nsec (set-millisecond-part nsec 0)))) 255 | (if this-ss 256 | (setf ss this-ss truncate nil) 257 | (if truncate (setf ss 0))) 258 | (if this-mm 259 | (setf mm this-mm truncate nil) 260 | (if truncate (setf mm 0))) 261 | (if this-hh 262 | (setf hh this-hh truncate nil) 263 | (if truncate (setf hh 0))) 264 | (if this-day 265 | (setf day this-day truncate nil) 266 | (if truncate (setf day 1))) 267 | (if this-month 268 | (setf month this-month truncate nil) 269 | (if truncate (setf month 1))) 270 | (if this-year 271 | (setf year this-year)))) 272 | (encode-timestamp nsec ss mm hh day month year)))) 273 | 274 | (declaim (inline year-of 275 | month-of 276 | day-of 277 | hour-of 278 | minute-of 279 | second-of 280 | millisecond-of 281 | microsecond-of 282 | nanosecond-of)) 283 | 284 | (defun year-of (fixed-time) 285 | (nth-value 6 (decode-timestamp fixed-time))) 286 | (defun month-of (fixed-time) 287 | (nth-value 5 (decode-timestamp fixed-time))) 288 | (defun day-of (fixed-time) 289 | (nth-value 4 (decode-timestamp fixed-time))) 290 | (defun hour-of (fixed-time) 291 | (nth-value 3 (decode-timestamp fixed-time))) 292 | (defun minute-of (fixed-time) 293 | (nth-value 2 (decode-timestamp fixed-time))) 294 | (defun second-of (fixed-time) 295 | (nth-value 1 (decode-timestamp fixed-time))) 296 | (defun millisecond-of (fixed-time) 297 | (millisecond-part (nth-value 0 (decode-timestamp fixed-time)))) 298 | (defun microsecond-of (fixed-time) 299 | (microsecond-part (nth-value 0 (decode-timestamp fixed-time)))) 300 | (defun nanosecond-of (fixed-time) 301 | (nanosecond-part (nth-value 0 (decode-timestamp fixed-time)))) 302 | 303 | (declaim (inline day-of-week)) 304 | (defun day-of-week (fixed-time) 305 | "Return the day of the week associated with a given FIXED-TIME. 306 | The result is a FIXNUM with 0 representing Sunday, through 6 on Saturday." 307 | (declare (type fixed-time fixed-time)) 308 | (nth-value 7 (decode-timestamp fixed-time))) 309 | 310 | (declaim (inline falls-on-weekend-p)) 311 | (defun falls-on-weekend-p (fixed-time) 312 | "Return T if the given FIXED-TIME occurs on a Saturday or Sunday." 313 | (let ((dow (day-of-week fixed-time))) 314 | (or (= 0 dow) (= 6 dow)))) 315 | 316 | ;;;_ * RELATIVE-DURATION 317 | 318 | (defstruct duration 319 | (years 0 :type integer) 320 | (months 0 :type integer) 321 | (days 0 :type integer) 322 | (hours 0 :type integer) 323 | (minutes 0 :type integer) 324 | (seconds 0 :type integer) 325 | (milliseconds 0 :type integer) 326 | (microseconds 0 :type integer) 327 | (nanoseconds 0 :type integer)) 328 | 329 | (declaim (inline duration)) 330 | (defun duration (&rest args) 331 | "Create a DURATION object. 332 | 333 | One thing to note about duration: there is no way to determine the total 334 | length of a duration in terms of any specific time quantity, without first 335 | binding that duration to a fixed point in time (after all, how many days are 336 | in a month if you don't know which month it is?) Therefore, those looking for 337 | a function like \"duration-seconds\" are really wanting to work with ranges, 338 | not just durations." 339 | (apply #'make-duration args)) 340 | 341 | (defmacro with-skippers (&body body) 342 | `(labels 343 | ((skip-year (skip) 344 | (incf year skip)) 345 | 346 | (skip-month (skip) 347 | (if (minusp skip) 348 | (let ((remainder (+ (1- month) skip))) 349 | (if (minusp remainder) 350 | (progn 351 | (skip-year -1) 352 | (setf month 12) 353 | (skip-month (1+ remainder))) 354 | (incf month skip))) 355 | (if (plusp skip) 356 | (let ((remainder (- (+ month skip) 12))) 357 | (if (plusp remainder) 358 | (progn 359 | (skip-year 1) 360 | (setf month 1) 361 | (skip-month (1- remainder))) 362 | (incf month skip)))))) 363 | 364 | (skip-day (skip) 365 | (if (minusp skip) 366 | (let ((remainder (+ (1- day) skip))) 367 | (if (minusp remainder) 368 | (progn 369 | (skip-month -1) 370 | (setf day (days-in-month month year)) 371 | (skip-day (1+ remainder))) 372 | (incf day skip))) 373 | (if (plusp skip) 374 | (let ((remainder (- (+ day skip) 375 | (days-in-month month year)))) 376 | (if (plusp remainder) 377 | (progn 378 | (skip-month 1) 379 | (setf day 1) 380 | (skip-day (1- remainder))) 381 | (incf day skip)))))) 382 | 383 | (skip-hour (skip) 384 | (if (minusp skip) 385 | (let ((remainder (+ hh skip))) 386 | (if (minusp remainder) 387 | (progn 388 | (skip-day -1) 389 | (setf hh 23) 390 | (skip-hour (1+ remainder))) 391 | (incf hh skip))) 392 | (if (plusp skip) 393 | (let ((remainder (- (+ hh skip) 23))) 394 | (if (plusp remainder) 395 | (progn 396 | (skip-day 1) 397 | (setf hh 0) 398 | (skip-hour (1- remainder))) 399 | (incf hh skip)))))) 400 | 401 | (skip-minute (skip) 402 | (if (minusp skip) 403 | (let ((remainder (+ mm skip))) 404 | (if (minusp remainder) 405 | (progn 406 | (skip-hour -1) 407 | (setf mm 59) 408 | (skip-minute (1+ remainder))) 409 | (incf mm skip))) 410 | (if (plusp skip) 411 | (let ((remainder (- (+ mm skip) 59))) 412 | (if (plusp remainder) 413 | (progn 414 | (skip-hour 1) 415 | (setf mm 0) 416 | (skip-minute (1- remainder))) 417 | (incf mm skip)))))) 418 | 419 | (skip-second (skip) 420 | (if (minusp skip) 421 | (let ((remainder (+ ss skip))) 422 | (if (minusp remainder) 423 | (progn 424 | (skip-minute -1) 425 | (setf ss 59) 426 | (skip-second (1+ remainder))) 427 | (incf ss skip))) 428 | (if (plusp skip) 429 | (let ((remainder (- (+ ss skip) 59))) 430 | (if (plusp remainder) 431 | (progn 432 | (skip-minute 1) 433 | (setf ss 0) 434 | (skip-second (1- remainder))) 435 | (incf ss skip)))))) 436 | 437 | (skip-millisecond (skip) 438 | (if (minusp skip) 439 | (let ((remainder (+ (millisecond-part nsec) skip))) 440 | (if (minusp remainder) 441 | (progn 442 | (skip-second -1) 443 | (setf nsec (set-millisecond-part nsec 999)) 444 | (skip-millisecond (1+ remainder))) 445 | (setf nsec (set-millisecond-part 446 | nsec (+ (millisecond-part nsec) skip))))) 447 | (if (plusp skip) 448 | (let ((remainder (- (+ (millisecond-part nsec) skip) 999))) 449 | (if (plusp remainder) 450 | (progn 451 | (skip-second 1) 452 | (setf nsec (set-millisecond-part nsec 0)) 453 | (skip-millisecond (1- remainder))) 454 | (setf nsec (set-millisecond-part 455 | nsec (+ (millisecond-part nsec) 456 | skip)))))))) 457 | 458 | (skip-microsecond (skip) 459 | (if (minusp skip) 460 | (let ((remainder (+ (microsecond-part nsec) skip))) 461 | (if (minusp remainder) 462 | (progn 463 | (skip-second -1) 464 | (setf nsec (set-microsecond-part nsec 999)) 465 | (skip-microsecond (1+ remainder))) 466 | (setf nsec (set-microsecond-part 467 | nsec (+ (microsecond-part nsec) skip))))) 468 | (if (plusp skip) 469 | (let ((remainder (- (+ (microsecond-part nsec) skip) 999))) 470 | (if (plusp remainder) 471 | (progn 472 | (skip-second 1) 473 | (setf nsec (set-microsecond-part nsec 0)) 474 | (skip-microsecond (1- remainder))) 475 | (setf nsec (set-microsecond-part 476 | nsec (+ (microsecond-part nsec) 477 | skip)))))))) 478 | 479 | (skip-nanosecond (skip) 480 | (if (minusp skip) 481 | (let ((remainder (+ (nanosecond-part nsec) skip))) 482 | (if (minusp remainder) 483 | (progn 484 | (skip-second -1) 485 | (setf nsec (set-nanosecond-part nsec 999)) 486 | (skip-nanosecond (1+ remainder))) 487 | (setf nsec (set-nanosecond-part 488 | nsec (+ (nanosecond-part nsec) skip))))) 489 | (if (plusp skip) 490 | (let ((remainder (- (+ (nanosecond-part nsec) skip) 999))) 491 | (if (plusp remainder) 492 | (progn 493 | (skip-second 1) 494 | (setf nsec (set-nanosecond-part nsec 0)) 495 | (skip-nanosecond (1- remainder))) 496 | (setf nsec (set-nanosecond-part 497 | nsec (+ (nanosecond-part nsec) 498 | skip))))))))) 499 | ,@body)) 500 | 501 | (defun add-time (fixed-time duration &key (reverse nil)) 502 | "Given a FIXED-TIME, add the supplied DURATION. 503 | 504 | Example (reader notation requires calling LOCAL-TIME:ENABLE-READ-MACROS): 505 | 506 | (add-time @2007-05-20T12:10:10.000 (duration :hours 50)) 507 | => @2007-05-22T14:10:10.000 508 | 509 | NOTE: This function always adds the largest increments first, so: 510 | 511 | (add-time @2003-01-09 (duration :years 1 :days 20)) => @2004-02-29 512 | 513 | If days has been added before years, the result would have been 514 | \"@2004-03-01\"." 515 | (declare (type fixed-time fixed-time)) 516 | (declare (type duration duration)) 517 | (declare (type boolean reverse)) 518 | (if (and (zerop (duration-years duration)) 519 | (zerop (duration-months duration)) 520 | (zerop (duration-days duration)) 521 | (zerop (duration-hours duration)) 522 | (zerop (duration-minutes duration))) 523 | (multiple-value-bind (quotient remainder) 524 | (floor (funcall (if reverse #'- #'+) 525 | (+ (* (timestamp-to-unix fixed-time) 1000000000) 526 | (nsec-of fixed-time)) 527 | (+ (* (duration-seconds duration) 1000000000) 528 | (* (duration-milliseconds duration) 1000000) 529 | (* (duration-microseconds duration) 1000) 530 | (duration-nanoseconds duration))) 531 | 1000000000) 532 | (unix-to-timestamp quotient :nsec remainder)) 533 | (multiple-value-bind 534 | (nsec ss mm hh day month year) 535 | (decode-timestamp fixed-time) 536 | (let ((identity (if reverse -1 1))) 537 | (with-skippers 538 | (if (duration-years duration) 539 | (skip-year (* identity (duration-years duration)))) 540 | (if (duration-months duration) 541 | (skip-month (* identity (duration-months duration)))) 542 | (if (duration-days duration) 543 | (skip-day (* identity (duration-days duration)))) 544 | (if (duration-hours duration) 545 | (skip-hour (* identity (duration-hours duration)))) 546 | (if (duration-minutes duration) 547 | (skip-minute (* identity (duration-minutes duration)))) 548 | (if (duration-seconds duration) 549 | (skip-second (* identity (duration-seconds duration)))) 550 | (if (duration-milliseconds duration) 551 | (skip-millisecond (* identity (duration-milliseconds duration)))) 552 | (if (duration-microseconds duration) 553 | (skip-microsecond (* identity (duration-microseconds duration)))) 554 | (if (duration-nanoseconds duration) 555 | (skip-nanosecond (* identity (duration-nanoseconds duration)))))) 556 | (encode-timestamp nsec ss mm hh day month year)))) 557 | 558 | (declaim (inline subtract-time)) 559 | (defun subtract-time (fixed-time duration) 560 | (add-time fixed-time duration :reverse t)) 561 | 562 | (defun bounded-add (left right bound) 563 | "A bounded addition operator. Returns: VALUE CARRY." 564 | (assert (< left bound)) 565 | (multiple-value-bind (quotient remainder) 566 | (floor right bound) 567 | (let ((sum (+ left remainder))) 568 | (if (< sum bound) 569 | (values sum quotient) 570 | (values (- (+ left remainder) bound) 571 | (+ 1 quotient)))))) 572 | 573 | (defun bounded-subtract (left right bound) 574 | "A bounded subtraction operator. Returns: VALUE CARRY." 575 | (assert (< left bound)) 576 | (multiple-value-bind (quotient remainder) 577 | (floor right bound) 578 | (if (>= left remainder) 579 | (values (- left remainder) quotient) 580 | (values (+ left (- bound remainder)) 581 | (+ 1 quotient))))) 582 | 583 | (declaim (inline add-years subtract-years)) 584 | (defun add-years (duration years) 585 | (incf (duration-years duration) years) 586 | duration) 587 | (defun subtract-years (duration years) 588 | (decf (duration-years duration) years) 589 | duration) 590 | 591 | (declaim (inline add-months subtract-months)) 592 | (defun add-months (duration months) 593 | (incf (duration-months duration) months) 594 | duration) 595 | (defun subtract-months (duration months) 596 | (decf (duration-months duration) months) 597 | duration) 598 | 599 | (declaim (inline add-days subtract-days)) 600 | (defun add-days (duration days) 601 | (incf (duration-days duration) days) 602 | duration) 603 | (defun subtract-days (duration days) 604 | (decf (duration-days duration) days) 605 | duration) 606 | 607 | (declaim (inline add-hours subtract-hours)) 608 | (defun add-hours (duration hours) 609 | (incf (duration-hours duration) hours) 610 | duration) 611 | (defun subtract-hours (duration hours) 612 | (decf (duration-hours duration) hours) 613 | duration) 614 | 615 | (declaim (inline add-minutes subtract-minutes)) 616 | (defun add-minutes (duration minutes) 617 | (incf (duration-minutes duration) minutes) 618 | duration) 619 | (defun subtract-minutes (duration minutes) 620 | (decf (duration-minutes duration) minutes) 621 | duration) 622 | 623 | (declaim (inline add-seconds subtract-seconds)) 624 | (defun add-seconds (duration seconds) 625 | (incf (duration-seconds duration) seconds) 626 | duration) 627 | (defun subtract-seconds (duration seconds) 628 | (decf (duration-seconds duration) seconds) 629 | duration) 630 | 631 | (declaim (inline add-milliseconds subtract-milliseconds)) 632 | (defun add-milliseconds (duration milliseconds) 633 | (incf (duration-milliseconds duration) milliseconds) 634 | duration) 635 | (defun subtract-milliseconds (duration milliseconds) 636 | (decf (duration-milliseconds duration) milliseconds) 637 | duration) 638 | 639 | (declaim (inline add-microseconds subtract-microseconds)) 640 | (defun add-microseconds (duration microseconds) 641 | (incf (duration-microseconds duration) microseconds) 642 | duration) 643 | (defun subtract-microseconds (duration microseconds) 644 | (decf (duration-microseconds duration) microseconds) 645 | duration) 646 | 647 | (declaim (inline add-nanoseconds subtract-nanoseconds)) 648 | (defun add-nanoseconds (duration nanoseconds) 649 | (incf (duration-nanoseconds duration) nanoseconds) 650 | duration) 651 | (defun subtract-nanoseconds (duration nanoseconds) 652 | (decf (duration-nanoseconds duration) nanoseconds) 653 | duration) 654 | 655 | (defun time-difference (left right) 656 | "Compute the duration existing between fixed-times LEFT and RIGHT. 657 | 658 | The order of left or right is ignored; the returned DURATION, if added to 659 | the earlier value, will result in the later. 660 | 661 | A complexity of this process which might surprise some is that larger 662 | quantities are added by ADD-TIME before smaller quantities. For example, what 663 | is the difference between 2003-02-10 and 2004-03-01? If you add years before 664 | days, the difference is 1 year and 20 days. If you were to add days before 665 | years, however, the difference would be 1 year and 21 days. The question, do 666 | you advance to 2004 and then calculate between 2-10 and 3-01, or do you move 667 | from 2-10 to 3-01, and then increment the year? This library chooses to add 668 | years before days, since this follows human reckoning a bit closer (i.e., a 669 | person would likely flip to the 2004 calendar and then start counting off 670 | days, rather than the other way around). This difference in reckoning can be 671 | tricky, however, so bear this in mind." 672 | (if (timestamp< left right) 673 | (rotatef left right)) 674 | (let ((nsec (- (nsec-of left) (nsec-of right))) 675 | (sec (- (timestamp-to-universal left) (timestamp-to-universal right)))) 676 | (if (minusp nsec) 677 | (decf sec)) 678 | (duration :seconds sec :nanoseconds nsec))) 679 | 680 | (declaim (inline add-duration)) 681 | (defun add-duration (left right) 682 | "Add one duration to another." 683 | (duration :years (+ (duration-years left) 684 | (duration-years right)) 685 | :months (+ (duration-months left) 686 | (duration-months right)) 687 | :days (+ (duration-days left) 688 | (duration-days right)) 689 | :hours (+ (duration-hours left) 690 | (duration-hours right)) 691 | :minutes (+ (duration-minutes left) 692 | (duration-minutes right)) 693 | :seconds (+ (duration-seconds left) 694 | (duration-seconds right)) 695 | :milliseconds (+ (duration-milliseconds left) 696 | (duration-milliseconds right)) 697 | :microseconds (+ (duration-microseconds left) 698 | (duration-microseconds right)) 699 | :nanoseconds (+ (duration-nanoseconds left) 700 | (duration-nanoseconds right)))) 701 | 702 | (declaim (inline subtract-duration)) 703 | (defun subtract-duration (left right) 704 | "Subtract one duration from another." 705 | (duration :years (- (duration-years left) 706 | (duration-years right)) 707 | :months (- (duration-months left) 708 | (duration-months right)) 709 | :days (- (duration-days left) 710 | (duration-days right)) 711 | :hours (- (duration-hours left) 712 | (duration-hours right)) 713 | :minutes (- (duration-minutes left) 714 | (duration-minutes right)) 715 | :seconds (- (duration-seconds left) 716 | (duration-seconds right)) 717 | :milliseconds (- (duration-milliseconds left) 718 | (duration-milliseconds right)) 719 | :microseconds (- (duration-microseconds left) 720 | (duration-microseconds right)) 721 | :nanoseconds (- (duration-nanoseconds left) 722 | (duration-nanoseconds right)))) 723 | 724 | (declaim (inline multiply-duration)) 725 | (defun multiply-duration (left multiplier) 726 | "Add one duration to another." 727 | (duration :years (* (duration-years left) multiplier) 728 | :months (* (duration-months left) multiplier) 729 | :days (* (duration-days left) multiplier) 730 | :hours (* (duration-hours left) multiplier) 731 | :minutes (* (duration-minutes left) multiplier) 732 | :seconds (* (duration-seconds left) multiplier) 733 | :milliseconds (* (duration-milliseconds left) multiplier) 734 | :microseconds (* (duration-microseconds left) multiplier) 735 | :nanoseconds (* (duration-nanoseconds left) multiplier))) 736 | 737 | (declaim (inline time-stepper)) 738 | (defun time-stepper (duration &key (reverse nil)) 739 | (declare (type duration duration)) 740 | (declare (type boolean reverse)) 741 | (lambda (time) 742 | (add-time time duration :reverse reverse))) 743 | 744 | (declaim (inline time-generator)) 745 | (defun time-generator (start duration &key (reverse nil)) 746 | (declare (type fixed-time start)) 747 | (declare (type duration duration)) 748 | (declare (type boolean reverse)) 749 | (let (next) 750 | (lambda () 751 | (setf next (add-time (or next start) duration 752 | :reverse reverse))))) 753 | 754 | (defmacro loop-times (forms start duration end 755 | &key (reverse nil) (inclusive-p nil)) 756 | "Map over a set of times separated by DURATION, calling CALLABLE with the 757 | start of each." 758 | (let ((generator-sym (gensym)) 759 | (start-sym (gensym)) 760 | (end-sym (gensym))) 761 | `(let ((,start-sym ,start) 762 | (,end-sym ,end)) 763 | (assert (,(if reverse 764 | 'timestamp> 765 | 'timestamp<) ,start-sym ,end-sym)) 766 | (loop 767 | with ,generator-sym = (time-generator ,start-sym ,duration) 768 | for value = (funcall ,generator-sym) 769 | while ,(if reverse 770 | (if inclusive-p 771 | `(timestamp>= value ,end-sym) 772 | `(timestamp> value ,end-sym)) 773 | (if inclusive-p 774 | `(timestamp<= value ,end-sym) 775 | `(timestamp< value ,end-sym))) 776 | ,@forms)))) 777 | 778 | (defmacro map-times (callable start duration end 779 | &key (reverse nil) (inclusive-p nil)) 780 | "Map over a set of times separated by DURATION, calling CALLABLE with the 781 | start of each." 782 | `(loop-times (do (funcall ,callable value)) 783 | ,start ,duration ,end :reverse ,reverse 784 | :inclusive-p ,inclusive-p)) 785 | 786 | (defmacro list-times (start duration end 787 | &key (reverse nil) (inclusive-p nil)) 788 | "Return a list of all times within the given range." 789 | `(loop-times (collect value) 790 | ,start ,duration ,end :reverse ,reverse 791 | :inclusive-p ,inclusive-p)) 792 | 793 | (defmacro do-times ((var start duration end &optional (result nil)) 794 | &body body) 795 | "A 'do' style version of the functional MAP-TIMES macro. 796 | 797 | The disadvantage to DO-TIMES is that there is no way to ask for a reversed 798 | time sequence, or specify an inclusive endpoint." 799 | `(block nil 800 | (map-times #'(lambda (,var) ,@body) ,start ,duration ,end) 801 | ,result)) 802 | 803 | ;;;_ * RELATIVE-TIME 804 | 805 | (defstruct relative-time 806 | (year nil :type (or keyword integer null)) 807 | (month nil :type (or keyword integer null)) 808 | (week nil :type (or keyword integer null)) 809 | (day-of-week nil :type (or keyword integer null)) 810 | (day nil :type (or keyword integer null)) 811 | (hour nil :type (or keyword integer null)) 812 | (minute nil :type (or keyword integer null)) 813 | (second nil :type (or keyword integer null)) 814 | (millisecond nil :type (or keyword integer null)) 815 | (microsecond nil :type (or keyword integer null)) 816 | (nanosecond nil :type (or keyword integer null))) 817 | 818 | (declaim (inline relative-time)) 819 | (defun relative-time (&rest args) 820 | (apply #'make-relative-time args)) 821 | 822 | (declaim (inline range-dec)) 823 | (defun range-dec (value min max) 824 | (if (= value min) 825 | max 826 | (1- value))) 827 | 828 | (declaim (inline range-inc)) 829 | (defun range-inc (value min max) 830 | (if (= value max) 831 | min 832 | (1+ value))) 833 | 834 | (defun enclosing-duration (relative-time) 835 | "Return a DURATION which, if applied to a time, causes NEXT-TIME to move to 836 | the next matching occurrence of that time pattern. 837 | 838 | For example, if you ask for ':day 18' on Nov 18, it will return the same 839 | time back to you. If you add enclosing duration for that relative time to Nov 840 | 18 and then ask again, you'll get Dec 18." 841 | (cond 842 | ((relative-time-month relative-time) 843 | (duration :months 1)) 844 | ((relative-time-day relative-time) 845 | (duration :days 1)) 846 | ((relative-time-hour relative-time) 847 | (duration :hours 1)) 848 | ((relative-time-minute relative-time) 849 | (duration :minutes 1)) 850 | ((relative-time-second relative-time) 851 | (duration :seconds 1)) 852 | ((relative-time-millisecond relative-time) 853 | (duration :milliseconds 1)) 854 | ((relative-time-microsecond relative-time) 855 | (duration :microseconds 1)) 856 | ((relative-time-nanosecond relative-time) 857 | (duration :nanoseconds 1)) 858 | ((relative-time-day-of-week relative-time) 859 | (duration :days 1)) 860 | (t 861 | (error "`enclosing-duration' has failed.")))) 862 | 863 | (defun details-match-relative-time-p (relative-time nsec ss mm hh day month year 864 | day-of-week daylight-p 865 | timezone tz-abbrev) 866 | (declare (ignore daylight-p)) 867 | (declare (ignore timezone)) 868 | (declare (ignore tz-abbrev)) 869 | "Return T if the given time elements honor the details in RELATIVE-TIME." 870 | (and (or (not (relative-time-nanosecond relative-time)) 871 | (= (nanosecond-part nsec) 872 | (relative-time-nanosecond relative-time))) 873 | (or (not (relative-time-microsecond relative-time)) 874 | (= (microsecond-part nsec) 875 | (relative-time-microsecond relative-time))) 876 | (or (not (relative-time-millisecond relative-time)) 877 | (= (millisecond-part nsec) 878 | (relative-time-millisecond relative-time))) 879 | (or (not (relative-time-second relative-time)) 880 | (= ss (relative-time-second relative-time))) 881 | (or (not (relative-time-minute relative-time)) 882 | (= mm (relative-time-minute relative-time))) 883 | (or (not (relative-time-hour relative-time)) 884 | (= hh (relative-time-hour relative-time))) 885 | (or (not (relative-time-day relative-time)) 886 | (= day (relative-time-day relative-time))) 887 | (or (not (relative-time-month relative-time)) 888 | (= month (relative-time-month relative-time))) 889 | (or (not (relative-time-year relative-time)) 890 | (= year (relative-time-year relative-time))) 891 | (or (not (relative-time-day-of-week relative-time)) 892 | (= day-of-week (relative-time-day-of-week relative-time))))) 893 | 894 | (declaim (inline matches-relative-time-p)) 895 | (defun matches-relative-time-p (fixed-time relative-time) 896 | "Return T if the given FIXED-TIME honors the details in RELATIVE-TIME." 897 | (apply #'details-match-relative-time-p 898 | relative-time (multiple-value-list (decode-timestamp fixed-time)))) 899 | 900 | ;; jww (2007-11-18): The following bug occurs: 901 | ;; (next-time @2008-04-01 (relative-time :month 2 :day 29)) 902 | ;; => @2009-03-29T00:33:08.004 903 | 904 | 905 | ;; jww (2007-11-22): This function fails to compile under CMUCL, although it 906 | ;; does work under SBCL and LispWorks. I get this: 907 | ;; 908 | ;; Error in function LISP::ASSERT-ERROR: 909 | ;; The assertion (MEMBER C::KIND '(:OPTIONAL :CLEANUP :ESCAPE)) failed. 910 | ;; [Condition of type SIMPLE-ERROR] 911 | 912 | (defun next-time (anchor relative-time 913 | &key (reverse nil) (accept-anchor nil) (recursive-call nil)) 914 | "Compute the first time after FIXED-TIME which matches RELATIVE-TIME. 915 | 916 | This function finds the first moment after FIXED-TIME which honors every 917 | element in RELATIVE-TIME: 918 | 919 | (next-time @2007-05-20 (relative-time :month 3)) => @2008-03-20 920 | 921 | The relative time constructor arguments may also be symbolic: 922 | 923 | (relative-time :month :this) 924 | (relative-time :month :next) 925 | (relative-time :month :prev) 926 | 927 | To find the date two weeks after next February, a combination of NEXT-TIME 928 | and ADD-TIME must be used, since \"next February\" is a relative time concept, 929 | while \"two weeks\" is a duration concept: 930 | 931 | (add-time (next-time @2007-05-20 (relative-time :month 2)) 932 | (duration :days 14)) 933 | 934 | NOTE: The keyword arguments to RELATIVE-TIME are always singular; those to 935 | DURATION are always plural. 936 | 937 | The following form resolves to the first sunday of the given year: 938 | 939 | (next-time (previous-time @2007-05-20 940 | (relative-time :month 1 :day 1)) 941 | (relative-time :week-day 0)) 942 | 943 | This form finds the first Friday the 13th after today: 944 | 945 | (next-time @2007-05-20 (relative-time :day 13 :day-of-week 5)) 946 | 947 | NOTE: When adding times, NEXT-TIME always seeks the next time that fully 948 | honors your request. If asked for Feb 29, the year of the resulting time will 949 | fall in a leap year. If asked for Thu, Apr 29, it returns the next occurrence 950 | of Apr 29 which falls on a Friday. Example: 951 | 952 | (next-time @2007-11-01 953 | (relative-time :month 4 :day 29 :day-of-week 4)) 954 | => @2010-04-29T00:00:00.000" 955 | (declare (type (or fixed-time null) anchor)) 956 | (declare (type relative-time relative-time)) 957 | (declare (type boolean reverse)) 958 | 959 | (let ((moment (or anchor (local-time:now)))) 960 | (multiple-value-bind 961 | (nsec ss mm hh day month year day-of-week) 962 | (decode-timestamp moment) 963 | 964 | ;; If the moment we just decoded already matches the relative-time, 965 | ;; either return it immediately (if :ACCEPT-ANCHOR is T), or else 966 | ;; recurse exactly one level to get the next relative time. 967 | (if (and (not recursive-call) 968 | (details-match-relative-time-p relative-time 969 | nsec ss mm hh day month year 970 | day-of-week nil nil nil)) 971 | (return-from next-time 972 | (if accept-anchor 973 | moment 974 | (next-time (add-time moment 975 | (enclosing-duration relative-time) 976 | :reverse reverse) 977 | relative-time 978 | :reverse reverse 979 | :recursive-call t)))) 980 | 981 | (let ((identity (if reverse -1 1)) 982 | (test (if reverse #'> #'<)) 983 | now-nsec now-ss now-mm now-hh 984 | now-day now-month now-year now-day-of-week) 985 | 986 | (labels 987 | ((decode-now () 988 | (if anchor 989 | (multiple-value-setq 990 | (now-nsec now-ss now-mm now-hh 991 | now-day now-month 992 | now-year now-day-of-week) 993 | (decode-timestamp (local-time:now))) 994 | (setf now-nsec nsec 995 | now-ss ss 996 | now-mm mm 997 | now-hh hh 998 | now-day day 999 | now-month month 1000 | now-year year))) 1001 | (now-nsec () (or now-nsec (progn (decode-now) now-nsec))) 1002 | (now-ss () (or now-ss (progn (decode-now) now-ss))) 1003 | (now-mm () (or now-mm (progn (decode-now) now-mm))) 1004 | (now-hh () (or now-hh (progn (decode-now) now-hh))) 1005 | (now-day () (or now-day (progn (decode-now) now-day))) 1006 | (now-month () (or now-month (progn (decode-now) now-month))) 1007 | (now-year () (or now-year (progn (decode-now) now-year)))) 1008 | 1009 | (with-skippers 1010 | (macrolet 1011 | ((set-time-value (sym now-func accessor 1012 | &optional min max skip-function) 1013 | `(let ((value (,accessor relative-time))) 1014 | (when value 1015 | (if (keywordp value) 1016 | (let ((now-value 1017 | ,(if (member now-func '(nanosecond-part 1018 | microsecond-part 1019 | millisecond-part)) 1020 | `(,now-func (now-nsec)) 1021 | `(,now-func)))) 1022 | (case value 1023 | (:this (setf value now-value)) 1024 | (:next (setf value 1025 | ,(if max 1026 | `(range-inc now-value ,min ,max) 1027 | `(1+ now-value)))) 1028 | (:prev (setf value 1029 | ,(if min 1030 | `(range-dec now-value ,min ,max) 1031 | `(- now-value)))) 1032 | (otherwise 1033 | (error "Unknown relative-time keyword for ~S: ~S" 1034 | (quote ,accessor) value))))) 1035 | 1036 | ,(if skip-function 1037 | `(if (funcall 1038 | test value 1039 | ,(if (member now-func '(nanosecond-part 1040 | microsecond-part 1041 | millisecond-part)) 1042 | `(,now-func nsec) 1043 | `,sym)) 1044 | (,skip-function (* identity 1)))) 1045 | 1046 | ,(if (member sym '(set-nanosecond-part 1047 | set-microsecond-part 1048 | set-millisecond-part)) 1049 | `(setf nsec (,sym nsec value)) 1050 | `(setf ,sym value)))))) 1051 | 1052 | (set-time-value set-nanosecond-part nanosecond-part 1053 | relative-time-nanosecond 0 999 skip-microsecond) 1054 | (set-time-value set-microsecond-part microsecond-part 1055 | relative-time-microsecond 0 999 skip-millisecond) 1056 | (set-time-value set-millisecond-part millisecond-part 1057 | relative-time-millisecond 0 999 skip-second) 1058 | (set-time-value ss now-ss relative-time-second 0 59 1059 | skip-minute) 1060 | (set-time-value mm now-mm relative-time-minute 0 59 1061 | skip-hour) 1062 | (set-time-value hh now-hh relative-time-hour 0 23 1063 | skip-day) 1064 | 1065 | (when (relative-time-day relative-time) 1066 | (unless 1067 | (if (relative-time-month relative-time) 1068 | (if (relative-time-year relative-time) 1069 | (<= (relative-time-day relative-time) 1070 | (days-in-month (relative-time-month relative-time) 1071 | (relative-time-year relative-time))) 1072 | (<= (relative-time-day relative-time) 1073 | (max 29 (days-in-month 1074 | (relative-time-month relative-time))))) 1075 | (<= (relative-time-day relative-time) 31)) 1076 | (error "Invalid day specifier in relative-time: ~S" 1077 | relative-time)) 1078 | (set-time-value day now-day relative-time-day 1 1079 | (days-in-month month year) 1080 | skip-month)) 1081 | 1082 | (set-time-value month now-month relative-time-month 1 12 1083 | skip-year) 1084 | (set-time-value year now-year relative-time-year) 1085 | 1086 | ;; if the day was 29, 30 or 31, skip forward until a date is found 1087 | ;; which makes the expression possible. That is, specifying :day 1088 | ;; 31 in April will result in a date of May 31.a 1089 | (do () ((<= day (days-in-month month year))) 1090 | (skip-month identity)) 1091 | 1092 | (if (relative-time-day-of-week relative-time) 1093 | (loop 1094 | for new-time = 1095 | (encode-timestamp nsec ss mm hh day month year) 1096 | for new-dow = (nth-value 7 (decode-timestamp new-time)) 1097 | while (/= new-dow (relative-time-day-of-week 1098 | relative-time)) 1099 | do (skip-day identity)))))) 1100 | 1101 | (encode-timestamp nsec ss mm hh day month year))))) 1102 | 1103 | (declaim (inline previous-time)) 1104 | (defun previous-time (anchor relative-time &key (accept-anchor nil)) 1105 | "This function is the reverse of `NEXT-TIME'. Please look there for more." 1106 | (next-time anchor relative-time :reverse t :accept-anchor accept-anchor)) 1107 | 1108 | (declaim (inline relative-time-stepper)) 1109 | (defun relative-time-stepper (relative-time &key (reverse nil)) 1110 | (declare (type relative-time relative-time)) 1111 | (declare (type boolean reverse)) 1112 | (lambda (time) 1113 | (next-time time relative-time :reverse reverse))) 1114 | 1115 | (declaim (inline relative-time-generator)) 1116 | (defun relative-time-generator (anchor relative-time &key (reverse nil)) 1117 | (declare (type relative-time relative-time)) 1118 | (declare (type (or fixed-time null) anchor)) 1119 | (declare (type boolean reverse)) 1120 | (let (next) 1121 | (lambda () 1122 | (setf next (next-time (or next anchor) relative-time 1123 | :reverse reverse))))) 1124 | 1125 | (defmacro loop-relative-times (forms anchor relative-time end 1126 | &key (reverse nil) (inclusive-p)) 1127 | (let ((generator-sym (gensym)) 1128 | (anchor-sym (gensym)) 1129 | (end-sym (gensym))) 1130 | `(let ((,anchor-sym ,anchor) 1131 | (,end-sym ,end)) 1132 | (loop 1133 | with ,generator-sym = 1134 | (relative-time-generator ,anchor-sym ,relative-time 1135 | :reverse ,reverse) 1136 | for value = (funcall ,generator-sym) 1137 | while ,(if reverse 1138 | (if inclusive-p 1139 | `(timestamp>= value ,end-sym) 1140 | `(timestamp> value ,end-sym)) 1141 | (if inclusive-p 1142 | `(timestamp<= value ,end-sym) 1143 | `(timestamp< value ,end-sym))) 1144 | ,@forms)))) 1145 | 1146 | (defmacro map-relative-times (callable anchor relative-time end 1147 | &key (reverse nil) (inclusive-p nil)) 1148 | "Map over a set of times separated by DURATION, calling CALLABLE with the 1149 | start of each." 1150 | `(loop-relative-times (do (funcall ,callable value)) 1151 | ,anchor ,relative-time ,end :reverse ,reverse 1152 | :inclusive-p ,inclusive-p)) 1153 | 1154 | (defmacro list-relative-times (anchor relative-time end 1155 | &key (reverse nil) (inclusive-p nil)) 1156 | "Return a list of all times within the given range." 1157 | `(loop-relative-times (collect value) 1158 | ,anchor ,relative-time ,end :reverse ,reverse 1159 | :inclusive-p ,inclusive-p)) 1160 | 1161 | (defmacro do-relative-times ((var anchor relative-time end 1162 | &optional (result nil)) &body body) 1163 | "A 'do' style version of the functional MAP-RELATIVE-TIMES macro. 1164 | 1165 | The disadvantage to DO-RELATIVE-TIMES is that there is no way to ask for a 1166 | reversed time sequence, or specify an inclusive endpoint." 1167 | `(block nil 1168 | (map-relative-times #'(lambda (,var) ,@body) 1169 | ,anchor ,relative-time ,end) 1170 | ,result)) 1171 | 1172 | ;; These routines return the present time if it matches 1173 | (declaim (inline this-monday 1174 | this-tuesday 1175 | this-wednesday 1176 | this-thursday 1177 | this-friday 1178 | this-saturday 1179 | this-sunday)) 1180 | 1181 | (defun this-monday (anchor &key (reverse nil)) 1182 | (next-time anchor (relative-time :day-of-week 1) :reverse reverse 1183 | :accept-anchor t)) 1184 | (defun this-tuesday (anchor &key (reverse nil)) 1185 | (next-time anchor (relative-time :day-of-week 2) :reverse reverse 1186 | :accept-anchor t)) 1187 | (defun this-wednesday (anchor &key (reverse nil)) 1188 | (next-time anchor (relative-time :day-of-week 3) :reverse reverse 1189 | :accept-anchor t)) 1190 | (defun this-thursday (anchor &key (reverse nil)) 1191 | (next-time anchor (relative-time :day-of-week 4) :reverse reverse 1192 | :accept-anchor t)) 1193 | (defun this-friday (anchor &key (reverse nil)) 1194 | (next-time anchor (relative-time :day-of-week 5) :reverse reverse 1195 | :accept-anchor t)) 1196 | (defun this-saturday (anchor &key (reverse nil)) 1197 | (next-time anchor (relative-time :day-of-week 6) :reverse reverse 1198 | :accept-anchor t)) 1199 | (defun this-sunday (anchor &key (reverse nil)) 1200 | (next-time anchor (relative-time :day-of-week 0) :reverse reverse 1201 | :accept-anchor t)) 1202 | 1203 | ;; These routines do not return the present time if it matches 1204 | (declaim (inline next-monday 1205 | next-tuesday 1206 | next-wednesday 1207 | next-thursday 1208 | next-friday 1209 | next-saturday 1210 | next-sunday)) 1211 | 1212 | (defun next-monday (anchor &key (reverse nil)) 1213 | (next-time anchor (relative-time :day-of-week 1) :reverse reverse)) 1214 | (defun next-tuesday (anchor &key (reverse nil)) 1215 | (next-time anchor (relative-time :day-of-week 2) :reverse reverse)) 1216 | (defun next-wednesday (anchor &key (reverse nil)) 1217 | (next-time anchor (relative-time :day-of-week 3) :reverse reverse)) 1218 | (defun next-thursday (anchor &key (reverse nil)) 1219 | (next-time anchor (relative-time :day-of-week 4) :reverse reverse)) 1220 | (defun next-friday (anchor &key (reverse nil)) 1221 | (next-time anchor (relative-time :day-of-week 5) :reverse reverse)) 1222 | (defun next-saturday (anchor &key (reverse nil)) 1223 | (next-time anchor (relative-time :day-of-week 6) :reverse reverse)) 1224 | (defun next-sunday (anchor &key (reverse nil)) 1225 | (next-time anchor (relative-time :day-of-week 0) :reverse reverse)) 1226 | 1227 | ;; These routines do not return the present time if it matches 1228 | (declaim (inline previous-monday 1229 | previous-tuesday 1230 | previous-wednesday 1231 | previous-thursday 1232 | previous-friday 1233 | previous-saturday 1234 | previous-sunday)) 1235 | 1236 | (defun previous-monday (anchor) 1237 | (previous-time anchor (relative-time :day-of-week 1))) 1238 | (defun previous-tuesday (anchor) 1239 | (previous-time anchor (relative-time :day-of-week 2))) 1240 | (defun previous-wednesday (anchor) 1241 | (previous-time anchor (relative-time :day-of-week 3))) 1242 | (defun previous-thursday (anchor) 1243 | (previous-time anchor (relative-time :day-of-week 4))) 1244 | (defun previous-friday (anchor) 1245 | (previous-time anchor (relative-time :day-of-week 5))) 1246 | (defun previous-saturday (anchor) 1247 | (previous-time anchor (relative-time :day-of-week 6))) 1248 | (defun previous-sunday (anchor) 1249 | (previous-time anchor (relative-time :day-of-week 0))) 1250 | 1251 | (defun year-begin (anchor) 1252 | (previous-time anchor (relative-time :month 1 :day 1 :hour 0 1253 | :minute 0 :second 0 1254 | :millisecond 0 1255 | :microsecond 0 1256 | :nanosecond 0) 1257 | :accept-anchor t)) 1258 | 1259 | (defun month-begin (anchor) 1260 | (previous-time anchor (relative-time :day 1 :hour 0 1261 | :minute 0 :second 0 1262 | :millisecond 0 1263 | :microsecond 0 1264 | :nanosecond 0) 1265 | :accept-anchor t)) 1266 | 1267 | (defun sunday-week-begin (anchor) 1268 | (previous-time anchor (relative-time :day-of-week 0 :hour 0 1269 | :minute 0 :second 0 1270 | :millisecond 0 1271 | :microsecond 0 1272 | :nanosecond 0) 1273 | :accept-anchor t)) 1274 | 1275 | (defun monday-week-begin (anchor) 1276 | (previous-time anchor (relative-time :day-of-week 1 :hour 0 1277 | :minute 0 :second 0 1278 | :millisecond 0 1279 | :microsecond 0 1280 | :nanosecond 0) 1281 | :accept-anchor t)) 1282 | 1283 | (defun day-begin (anchor) 1284 | (previous-time anchor (relative-time :hour 0 :minute 0 :second 0 1285 | :millisecond 0 1286 | :microsecond 0 1287 | :nanosecond 0) 1288 | :accept-anchor t)) 1289 | 1290 | (defun hour-begin (anchor) 1291 | (previous-time anchor (relative-time :minute 0 :second 0 1292 | :millisecond 0 1293 | :microsecond 0 1294 | :nanosecond 0) 1295 | :accept-anchor t)) 1296 | 1297 | (defun minute-begin (anchor) 1298 | (previous-time anchor (relative-time :second 0 :millisecond 0 1299 | :microsecond 0 :nanosecond 0) 1300 | :accept-anchor t)) 1301 | 1302 | (defun second-begin (anchor) 1303 | (previous-time anchor (relative-time :millisecond 0 :microsecond 0 1304 | :nanosecond 0) 1305 | :accept-anchor t)) 1306 | 1307 | (defun millisecond-begin (anchor) 1308 | (previous-time anchor (relative-time :microsecond 0 :nanosecond 0) 1309 | :accept-anchor t)) 1310 | 1311 | (defun microsecond-begin (anchor) 1312 | (previous-time anchor (relative-time :nanosecond 0) 1313 | :accept-anchor t)) 1314 | 1315 | (defun year-end (anchor &key (inclusive-p nil)) 1316 | (let ((time (next-time anchor (relative-time :month 1 1317 | :day 1 1318 | :hour 0 1319 | :minute 0 1320 | :second 0 1321 | :millisecond 0 1322 | :microsecond 0 1323 | :nanosecond 0)))) 1324 | (if inclusive-p 1325 | time 1326 | (subtract-time time (duration :nanoseconds 1))))) 1327 | 1328 | (defun month-end (anchor &key (inclusive-p nil)) 1329 | (let ((time (next-time anchor (relative-time :day 1 1330 | :hour 0 1331 | :minute 0 1332 | :second 0 1333 | :millisecond 0 1334 | :microsecond 0 1335 | :nanosecond 0)))) 1336 | (if inclusive-p 1337 | time 1338 | (subtract-time time (duration :nanoseconds 1))))) 1339 | 1340 | (defun sunday-week-end (anchor &key (inclusive-p nil)) 1341 | (let ((time (next-sunday anchor))) 1342 | (if inclusive-p 1343 | time 1344 | (subtract-time time (duration :nanoseconds 1))))) 1345 | 1346 | (defun monday-week-end (anchor &key (inclusive-p nil)) 1347 | (let ((time (next-monday anchor))) 1348 | (if inclusive-p 1349 | time 1350 | (subtract-time time (duration :nanoseconds 1))))) 1351 | 1352 | (defun day-end (anchor &key (inclusive-p nil)) 1353 | (let ((time (next-time anchor (relative-time :hour 0 1354 | :minute 0 1355 | :second 0 1356 | :millisecond 0 1357 | :microsecond 0 1358 | :nanosecond 0)))) 1359 | (if inclusive-p 1360 | time 1361 | (subtract-time time (duration :nanoseconds 1))))) 1362 | 1363 | (defun hour-end (anchor &key (inclusive-p nil)) 1364 | (let ((time (next-time anchor (relative-time :minute 0 1365 | :second 0 1366 | :millisecond 0 1367 | :microsecond 0 1368 | :nanosecond 0)))) 1369 | (if inclusive-p 1370 | time 1371 | (subtract-time time (duration :nanoseconds 1))))) 1372 | 1373 | (defun minute-end (anchor &key (inclusive-p nil)) 1374 | (let ((time (next-time anchor (relative-time :second 0 1375 | :millisecond 0 1376 | :microsecond 0 1377 | :nanosecond 0)))) 1378 | (if inclusive-p 1379 | time 1380 | (subtract-time time (duration :nanoseconds 1))))) 1381 | 1382 | (defun second-end (anchor &key (inclusive-p nil)) 1383 | (let ((time (next-time anchor (relative-time :millisecond 0 1384 | :microsecond 0 1385 | :nanosecond 0)))) 1386 | (if inclusive-p 1387 | time 1388 | (subtract-time time (duration :nanoseconds 1))))) 1389 | 1390 | (defun millisecond-end (anchor &key (inclusive-p nil)) 1391 | (let ((time (next-time anchor (relative-time :microsecond 0 1392 | :nanosecond 0)))) 1393 | (if inclusive-p 1394 | time 1395 | (subtract-time time (duration :nanoseconds 1))))) 1396 | 1397 | (defun microsecond-end (anchor &key (inclusive-p nil)) 1398 | (let ((time (next-time anchor (relative-time :nanosecond 0)))) 1399 | (if inclusive-p 1400 | time 1401 | (subtract-time time (duration :nanoseconds 1))))) 1402 | 1403 | (defun this-year (&optional fixed-time) 1404 | (year-begin fixed-time)) 1405 | (defun this-month (&optional fixed-time) 1406 | (month-begin fixed-time)) 1407 | (defun this-sunday-week (&optional fixed-time) 1408 | (sunday-week-begin fixed-time)) 1409 | (defun this-monday-week (&optional fixed-time) 1410 | (monday-week-begin fixed-time)) 1411 | (defun this-day (&optional fixed-time) 1412 | (day-begin fixed-time)) 1413 | (defun this-hour (&optional fixed-time) 1414 | (hour-begin fixed-time)) 1415 | (defun this-minute (&optional fixed-time) 1416 | (minute-begin fixed-time)) 1417 | (defun this-second (&optional fixed-time) 1418 | (second-begin fixed-time)) 1419 | (defun this-millisecond (&optional fixed-time) 1420 | (millisecond-begin fixed-time)) 1421 | (defun this-microsecond (&optional fixed-time) 1422 | (microsecond-begin fixed-time)) 1423 | 1424 | (defun next-year (&optional fixed-time) 1425 | (year-end fixed-time :inclusive-p t)) 1426 | (defun next-month (&optional fixed-time) 1427 | (month-end fixed-time :inclusive-p t)) 1428 | (defun next-sunday-week (&optional fixed-time) 1429 | (sunday-week-end fixed-time :inclusive-p t)) 1430 | (defun next-monday-week (&optional fixed-time) 1431 | (monday-week-end fixed-time :inclusive-p t)) 1432 | (defun next-day (&optional fixed-time) 1433 | (day-end fixed-time :inclusive-p t)) 1434 | (defun next-hour (&optional fixed-time) 1435 | (hour-end fixed-time :inclusive-p t)) 1436 | (defun next-minute (&optional fixed-time) 1437 | (minute-end fixed-time :inclusive-p t)) 1438 | (defun next-second (&optional fixed-time) 1439 | (second-end fixed-time :inclusive-p t)) 1440 | (defun next-millisecond (&optional fixed-time) 1441 | (millisecond-end fixed-time :inclusive-p t)) 1442 | (defun next-microsecond (&optional fixed-time) 1443 | (microsecond-end fixed-time :inclusive-p t)) 1444 | 1445 | (defun previous-year (&optional fixed-time) 1446 | (previous-time (year-begin fixed-time) 1447 | (relative-time :month 1 :day 1 :hour 0 1448 | :minute 0 :second 0 1449 | :millisecond 0 1450 | :microsecond 0 1451 | :nanosecond 0))) 1452 | (defun previous-month (&optional fixed-time) 1453 | (previous-time (month-begin fixed-time) 1454 | (relative-time :day 1 :hour 0 1455 | :minute 0 :second 0 1456 | :millisecond 0 1457 | :microsecond 0 1458 | :nanosecond 0))) 1459 | (defun previous-sunday-week (&optional fixed-time) 1460 | (previous-sunday (previous-time fixed-time (relative-time :day-of-week 0) 1461 | :accept-anchor t))) 1462 | (defun previous-monday-week (&optional fixed-time) 1463 | (previous-monday (previous-time fixed-time (relative-time :day-of-week 1) 1464 | :accept-anchor t))) 1465 | (defun previous-day (&optional fixed-time) 1466 | (previous-time (day-begin fixed-time) 1467 | (relative-time :hour 0 :minute 0 :second 0 1468 | :millisecond 0 1469 | :microsecond 0 1470 | :nanosecond 0))) 1471 | (defun previous-hour (&optional fixed-time) 1472 | (previous-time (hour-begin fixed-time) 1473 | (relative-time :minute 0 :second 0 1474 | :millisecond 0 1475 | :microsecond 0 1476 | :nanosecond 0))) 1477 | (defun previous-minute (&optional fixed-time) 1478 | (previous-time (minute-begin fixed-time) 1479 | (relative-time :second 0 :millisecond 0 1480 | :microsecond 0 1481 | :nanosecond 0))) 1482 | (defun previous-second (&optional fixed-time) 1483 | (previous-time (second-begin fixed-time) 1484 | (relative-time :millisecond 0 1485 | :microsecond 0 1486 | :nanosecond 0))) 1487 | (defun previous-millisecond (&optional fixed-time) 1488 | (previous-time (second-begin fixed-time) 1489 | (relative-time :microsecond 0 1490 | :nanosecond 0))) 1491 | (defun previous-nanosecond (&optional fixed-time) 1492 | (previous-time (second-begin fixed-time) 1493 | (relative-time :nanosecond 0))) 1494 | 1495 | ;;;_ * RANGE 1496 | 1497 | (defstruct (time-range (:conc-name get-range-)) 1498 | (fixed-begin nil) 1499 | (begin nil) 1500 | (begin-inclusive-p t) 1501 | (fixed-end nil) 1502 | (end nil) 1503 | (end-inclusive-p nil) 1504 | (duration nil) 1505 | (anchor nil)) 1506 | 1507 | (declaim (inline time-range)) 1508 | (defun time-range (&rest args) 1509 | (apply #'make-time-range args)) 1510 | 1511 | (defun time-range-begin (range) 1512 | (or (get-range-fixed-begin range) 1513 | (etypecase (get-range-begin range) 1514 | (fixed-time 1515 | (setf (get-range-fixed-begin range) 1516 | (get-range-begin range))) 1517 | 1518 | (relative-time 1519 | ;; jww (2007-11-26): What if a duration was set? 1520 | (setf (get-range-fixed-begin range) 1521 | (previous-time (time-range-anchor range) 1522 | (get-range-begin range) 1523 | :accept-anchor t))) 1524 | 1525 | (null 1526 | (and (get-range-end range) 1527 | (get-range-duration range) 1528 | (setf (get-range-begin range) 1529 | (subtract-time (time-range-end range) 1530 | (time-range-duration range)))))))) 1531 | 1532 | (defsetf time-range-begin (range) (value) 1533 | `(setf (get-range-begin ,range) ,value)) 1534 | 1535 | (defun time-range-begin-inclusive-p (range) 1536 | (get-range-begin-inclusive-p range)) 1537 | 1538 | (defun time-range-end (range) 1539 | (or (get-range-fixed-end range) 1540 | (etypecase (get-range-end range) 1541 | (fixed-time 1542 | (setf (get-range-fixed-end range) 1543 | (get-range-end range))) 1544 | 1545 | (relative-time 1546 | ;; jww (2007-11-26): What if a duration was set? 1547 | (setf (get-range-fixed-end range) 1548 | (previous-time (time-range-anchor range) 1549 | (get-range-end range) 1550 | :accept-anchor t))) 1551 | 1552 | (null 1553 | (and (get-range-begin range) 1554 | (get-range-duration range) 1555 | (setf (get-range-end range) 1556 | (add-time (time-range-begin range) 1557 | (time-range-duration range)))))))) 1558 | 1559 | (defun time-range-end-inclusive-p (range) 1560 | (get-range-end-inclusive-p range)) 1561 | 1562 | (defun time-range-duration (range) 1563 | (or (get-range-duration range) 1564 | (and (time-range-begin range) 1565 | (time-range-end range) 1566 | (setf (get-range-duration range) 1567 | (time-difference 1568 | (if (get-range-begin-inclusive-p range) 1569 | (get-range-begin range) 1570 | (add-time (get-range-begin range) 1571 | (duration :nanoseconds 1))) 1572 | (if (get-range-end-inclusive-p range) 1573 | (get-range-end range) 1574 | (subtract-time (get-range-end range) 1575 | (duration :nanoseconds 1)))))))) 1576 | 1577 | (defun time-range-anchor (range) 1578 | (or (get-range-anchor range) 1579 | (and (get-range-begin range) 1580 | (not (typep (get-range-begin range) 'relative-time)) 1581 | (setf (get-range-anchor range) (get-range-begin range))) 1582 | (and (get-range-end range) 1583 | (not (typep (get-range-end range) 'relative-time)) 1584 | (setf (get-range-anchor range) (get-range-end range))) 1585 | (setf (get-range-anchor range) (local-time:now)))) 1586 | 1587 | (defun time-within-range-p (fixed-time range) 1588 | (let ((begin (time-range-begin range)) 1589 | (end (time-range-end range))) 1590 | (and (or (null begin) 1591 | (if (get-range-begin-inclusive-p range) 1592 | (timestamp>= fixed-time begin) 1593 | (timestamp> fixed-time begin))) 1594 | (or (null end) 1595 | (if (get-range-end-inclusive-p range) 1596 | (timestamp<= fixed-time end) 1597 | (timestamp< fixed-time end)))))) 1598 | 1599 | (defun time-within-begin-end-p (fixed-time begin end) 1600 | (and (or (null begin) 1601 | (timestamp>= fixed-time begin)) 1602 | (or (null end) 1603 | (timestamp< fixed-time end)))) 1604 | 1605 | (defun time-range-next (range) 1606 | (let ((begin (get-range-begin range)) ; uncooked 1607 | (end (get-range-end range)) 1608 | (anchor (time-range-end range))) 1609 | (unless (or (null (time-range-begin range)) 1610 | (null (time-range-end range))) 1611 | (cond 1612 | ((typep begin 'relative-time) 1613 | (time-range :begin (next-time anchor begin) 1614 | :end (and (typep end 'relative-time) 1615 | (next-time anchor end)) 1616 | :duration (and (not (typep end 'relative-time)) 1617 | (time-range-duration range)))) 1618 | ((typep begin 'fixed-time) 1619 | (time-range :begin (add-time anchor (time-range-duration range)) 1620 | :end (and (typep end 'relative-time) 1621 | (next-time anchor end)) 1622 | :duration (and (not (typep end 'relative-time)) 1623 | (time-range-duration range)))))))) 1624 | 1625 | (defun time-range-previous (range) 1626 | (let ((begin (get-range-begin range)) ; uncooked 1627 | (end (get-range-end range)) 1628 | (anchor (time-range-begin range))) 1629 | (unless (or (null (time-range-begin range)) 1630 | (null (time-range-end range))) 1631 | (cond 1632 | ((typep begin 'relative-time) 1633 | (time-range :begin (previous-time anchor begin :accept-anchor t) 1634 | :end (and (typep end 'relative-time) 1635 | (previous-time anchor end :accept-anchor t)) 1636 | :duration (and (not (typep end 'relative-time)) 1637 | (time-range-duration range)))) 1638 | ((typep begin 'fixed-time) 1639 | (time-range :begin (subtract-time anchor (time-range-duration range)) 1640 | :end (and (typep end 'relative-time) 1641 | (previous-time anchor end :accept-anchor t)) 1642 | :duration (and (not (typep end 'relative-time)) 1643 | (time-range-duration range)))))))) 1644 | 1645 | (defun year-range (fixed-time &key (begin-inclusive-p t) 1646 | (end-inclusive-p nil)) 1647 | (time-range :begin (year-begin fixed-time) :end (next-year fixed-time) 1648 | :begin-inclusive-p begin-inclusive-p 1649 | :end-inclusive-p end-inclusive-p)) 1650 | (defun month-range (fixed-time &key (begin-inclusive-p t) 1651 | (end-inclusive-p nil)) 1652 | (time-range :begin (month-begin fixed-time) :end (next-month fixed-time) 1653 | :begin-inclusive-p begin-inclusive-p 1654 | :end-inclusive-p end-inclusive-p)) 1655 | (defun sunday-week-range (fixed-time &key (begin-inclusive-p t) 1656 | (end-inclusive-p nil)) 1657 | (time-range :begin (sunday-week-begin fixed-time) 1658 | :end (next-sunday-week fixed-time) 1659 | :begin-inclusive-p begin-inclusive-p 1660 | :end-inclusive-p end-inclusive-p)) 1661 | (defun monday-week-range (fixed-time &key (begin-inclusive-p t) 1662 | (end-inclusive-p nil)) 1663 | (time-range :begin (monday-week-begin fixed-time) 1664 | :end (next-monday-week fixed-time) 1665 | :begin-inclusive-p begin-inclusive-p 1666 | :end-inclusive-p end-inclusive-p)) 1667 | (defun day-range (fixed-time &key (begin-inclusive-p t) 1668 | (end-inclusive-p nil)) 1669 | (time-range :begin (day-begin fixed-time) :end (next-day fixed-time) 1670 | :begin-inclusive-p begin-inclusive-p 1671 | :end-inclusive-p end-inclusive-p)) 1672 | (defun hour-range (fixed-time &key (begin-inclusive-p t) 1673 | (end-inclusive-p nil)) 1674 | (time-range :begin (hour-begin fixed-time) :end (next-hour fixed-time) 1675 | :begin-inclusive-p begin-inclusive-p 1676 | :end-inclusive-p end-inclusive-p)) 1677 | (defun minute-range (fixed-time &key (begin-inclusive-p t) 1678 | (end-inclusive-p nil)) 1679 | (time-range :begin (minute-begin fixed-time) :end (next-minute fixed-time) 1680 | :begin-inclusive-p begin-inclusive-p 1681 | :end-inclusive-p end-inclusive-p)) 1682 | (defun second-range (fixed-time &key (begin-inclusive-p t) 1683 | (end-inclusive-p nil)) 1684 | (time-range :begin (second-begin fixed-time) :end (next-second fixed-time) 1685 | :begin-inclusive-p begin-inclusive-p 1686 | :end-inclusive-p end-inclusive-p)) 1687 | 1688 | (defun this-year-range () 1689 | (year-range (now))) 1690 | (defun this-month-range () 1691 | (month-range (now))) 1692 | (defun this-sunday-week-range () 1693 | (sunday-week-range (now))) 1694 | (defun this-monday-week-range () 1695 | (monday-week-range (now))) 1696 | (defun this-day-range () 1697 | (day-range (now))) 1698 | (defun this-hour-range () 1699 | (hour-range (now))) 1700 | (defun this-minute-range () 1701 | (minute-range (now))) 1702 | (defun this-second-range () 1703 | (second-range (now))) 1704 | 1705 | ;;;_ * PERIOD 1706 | 1707 | (defstruct time-period 1708 | (range) 1709 | (step) 1710 | (skip)) 1711 | 1712 | (defun time-period (&rest args) 1713 | (apply #'make-time-period args)) 1714 | 1715 | (defun time-period-begin (period) 1716 | (time-range-begin (time-period-range period))) 1717 | 1718 | (defun time-period-end (period) 1719 | (time-range-end (time-period-range period))) 1720 | 1721 | (defun time-period-generator (period) 1722 | (declare (type time-period period)) 1723 | (let ((step-stepper (time-stepper (time-period-step period))) 1724 | (skip-stepper (and (time-period-skip period) 1725 | (time-stepper (time-period-skip period)))) 1726 | (begin (time-period-begin period)) 1727 | (end (time-period-end period)) 1728 | (end-inclusive-p 1729 | (time-range-end-inclusive-p (time-period-range period)))) 1730 | (lambda () 1731 | (if begin 1732 | (let* ((this-end (funcall step-stepper begin)) 1733 | (next-begin (if skip-stepper 1734 | (funcall skip-stepper begin) 1735 | this-end))) 1736 | (when (and end next-begin) 1737 | (if (if end-inclusive-p 1738 | (timestamp> next-begin end) 1739 | (timestamp>= next-begin end)) 1740 | (setf next-begin nil))) 1741 | (multiple-value-prog1 1742 | (values begin this-end next-begin) 1743 | (setf begin next-begin))) 1744 | (values nil nil nil))))) 1745 | 1746 | (defmacro loop-time-period (forms period) 1747 | (let ((generator-sym (gensym))) 1748 | `(loop 1749 | with ,generator-sym = (time-period-generator ,period) 1750 | for (begin end next-begin) = 1751 | (multiple-value-list (funcall ,generator-sym)) 1752 | while begin 1753 | ,@forms))) 1754 | 1755 | (defmacro map-time-period (callable period) 1756 | `(loop-time-period (do (funcall ,callable begin end next-begin)) 1757 | ,period)) 1758 | 1759 | (defmacro list-time-period (period) 1760 | `(loop-time-period (collect (list begin end next-begin)) 1761 | ,period)) 1762 | 1763 | (defmacro do-time-period ((begin-var end-var next-begin-var period 1764 | &optional (result nil)) 1765 | &rest body) 1766 | `(block nil 1767 | (map-time-period 1768 | #'(lambda (,begin-var ,end-var ,next-begin-var) 1769 | ,@body) ,period) 1770 | ,result)) 1771 | 1772 | (defmacro with-timestamp-range ((min-symbol max-symbol 1773 | &optional (update 'update-range)) &body body) 1774 | "Define a context where (1) MIN-SYMBOL and MAX-SYMBOL are locally 1775 | bound variables with NIL default values and (2) UPDATE names a 1776 | lexically bound function which takes a timestamp and updates the 1777 | variables MIN-SYMBOL and MAX-SYMBOL so that they respectively hold the 1778 | earliest and latest timestamp after successive invocations. That 1779 | function finally returns its input value. For example, the following 1780 | code builds a TIME-RANGE instance from a list of dated transactions. 1781 | 1782 | (with-timestamp-range (earliest latest) 1783 | (dolist (tt transaction) 1784 | (update-range (transaction-date tt))) 1785 | (time-range :begin earliest :end latest :end-inclusive-p t)) 1786 | 1787 | A custom name can be used to nest invocations: 1788 | 1789 | (with-timestamp-range (earliest latest global-update-range) 1790 | (dolist (jj journals) 1791 | (with-timestamp-range (<< >>) 1792 | (dolist (tt (journal-xact jj)) 1793 | (gloal-update-range 1794 | (update-range (transaction-date tt)))) 1795 | (format t \"Journal earliest / latest: ~A / ~A~%\" << >>))) 1796 | (format t \"Global earliest / latest: ~A / ~A~%\" earliest latest)) 1797 | " 1798 | `(let (,min-symbol ,max-symbol) 1799 | (flet ((,update (date) 1800 | (prog1 date 1801 | (when (or (null ,min-symbol) 1802 | (local-time:timestamp< date ,min-symbol)) 1803 | (setf ,min-symbol date)) 1804 | (when (or (null ,max-symbol) 1805 | (local-time:timestamp> date ,max-symbol)) 1806 | (setf ,max-symbol date))))) 1807 | ,@body))) 1808 | 1809 | ;;;_ * Library functions 1810 | 1811 | ;;;_ + General purpose 1812 | 1813 | (defun sleep-until (fixed-time) 1814 | (let ((now (local-time:now))) 1815 | (when (local-time:timestamp> fixed-time now) 1816 | (let ((duration (time-difference fixed-time now))) 1817 | (sleep (/ (+ (* (duration-seconds duration) 1000000000) 1818 | (* (duration-milliseconds duration) 1000000) 1819 | (* (duration-microseconds duration) 1000) 1820 | (duration-nanoseconds duration)) 1000000000)))))) 1821 | 1822 | (provide 'periods) 1823 | 1824 | ;; periods.lisp ends here 1825 | -------------------------------------------------------------------------------- /strptime.lisp: -------------------------------------------------------------------------------- 1 | (declaim (optimize (debug 3) (safety 3) (speed 1) (space 0))) 2 | 3 | (in-package :periods) 4 | 5 | ;;;_ + FIXED-TIME parsing 6 | 7 | (declaim (inline read-integer)) 8 | (defun read-integer (in &optional length skip-whitespace-p) 9 | (let ((n 0)) 10 | (loop for i from 0 11 | for c = (peek-char nil in nil) 12 | until (or (null c) (and length (>= i length))) 13 | do (cond 14 | ((and skip-whitespace-p (char= c #\space)) 15 | (read-char in nil)) 16 | 17 | ((char<= #\0 c #\9) 18 | (setf n (+ (* n 10) (- (char-code (read-char in)) 48)))) 19 | 20 | (t 21 | (return)))) 22 | n)) 23 | 24 | (defun read-fixed-time (str in) 25 | (let (year (month 1) (day 1) (hour 0) (minute 0) (second 0)) 26 | (loop 27 | for c = (read-char in nil) 28 | for next = (peek-char nil str nil) 29 | while c 30 | do 31 | (if (char= c #\%) ; specifier 32 | (progn 33 | (setf c (read-char in)) 34 | (cond 35 | ((char= c #\%) 36 | (if (char= c next) 37 | (read-char str) 38 | (error "Expected '%', got '~C'" next))) 39 | 40 | ((char= c #\A)) ; full weekday name 41 | ((char= c #\a)) ; abbreviated weekday name 42 | 43 | ((char= c #\B)) ; full month name 44 | ((or (char= c #\b) ; abbreviated month name 45 | (char= c #\h))) ; same as %b 46 | 47 | ((char= c #\C) ; century, zero prefix 48 | (setf year (* 100 (read-integer str 2)))) 49 | 50 | ;;((char= c #\c)) ; national representation of date/time 51 | 52 | ((char= c #\D) ; equiv: %m/%d/%y 53 | (let ((date (read-fixed-time (make-string-input-stream "%m/%d/%y") 54 | str))) 55 | (setf year (nth 5 date) 56 | month (nth 4 date) 57 | day (nth 3 date)))) 58 | 59 | ((char= c #\d) 60 | (setf day (read-integer str 2)) 61 | ;; jww (2007-11-12): Check valid 62 | ) 63 | ((char= c #\e) ; day of month, space prefix 64 | (setf day (read-integer str 2 t))) 65 | 66 | ;;((char= c #\E)) ; POSIX locale extensions 67 | ;;((char= c #\O)) 68 | 69 | ((char= c #\F) ; equiv: %Y-%m-%d 70 | (let ((date (read-fixed-time (make-string-input-stream "%Y-%m-%d") 71 | str))) 72 | (setf year (nth 5 date) 73 | month (nth 4 date) 74 | day (nth 3 date)))) 75 | 76 | ((char= c #\G)) ; year as a decimal number with century 77 | ((char= c #\g)) ; same as %G, without century 78 | 79 | ((or (char= c #\H) 80 | (char= c #\I)) ; hour on the 12-hour clock 81 | (setf hour (read-integer str 2)) 82 | (if (> hour 24) 83 | (error "Hours exceed maximum range: ~D" hour))) 84 | 85 | ((or (char= c #\k) ; hour, space prefix 86 | (char= c #\l)) ; 12-hour hour, space prefix 87 | (setf hour (read-integer str 2 t))) 88 | 89 | ((char= c #\j)) ; day of the year as a decimal 90 | 91 | ((char= c #\M) 92 | (setf minute (read-integer str 2)) 93 | (if (> minute 59) 94 | (error "Minutes exceed maximum range: ~D" minute))) 95 | 96 | ((char= c #\m) 97 | (setf month (read-integer str 2)) 98 | ;; jww (2007-11-12): Check validity 99 | (if (or (< month 1) 100 | (> month 12)) 101 | (error "Month exceeds possible range: ~D" month))) 102 | 103 | ((char= c #\p)) ; national AM/PM, as appropriate 104 | 105 | ((char= c #\R) ; equiv: %H:%M 106 | (let ((date (read-fixed-time (make-string-input-stream "%H:%M") 107 | str))) 108 | (setf hour (nth 2 date) 109 | minute (nth 1 date)))) 110 | 111 | ((char= c #\r) ; equiv: %I:%M:%S %p 112 | (let ((date (read-fixed-time (make-string-input-stream "%I:%M:%S %p") 113 | str))) 114 | (setf hour (nth 2 date) 115 | minute (nth 1 date) 116 | second (nth 0 date)))) 117 | 118 | ((char= c #\S) 119 | (setf second (read-integer str 2)) 120 | (if (> second 59) 121 | (error "Seconds exceed maximum range: ~D" second))) 122 | 123 | ((char= c #\s)) ; seconds since Epoch, UTC (unix time) 124 | 125 | ((char= c #\T) ; equiv: %H:%M:%S 126 | (let ((date (read-fixed-time (make-string-input-stream "%H:%M:%S") 127 | str))) 128 | (setf hour (nth 2 date) 129 | minute (nth 1 date) 130 | second (nth 0 date)))) 131 | 132 | ((char= c #\t) ; tab 133 | (unless (char= #\Tab (read-char str)) 134 | (error "Expected a tab character, got '~C'" next))) 135 | 136 | ((char= c #\U)) ; week number of the year (Sun) 00-53 137 | ((char= c #\u)) ; weekday as a decimal (Mon) 1-7 138 | ((char= c #\V)) ; week of the year 1-53 (*) 139 | 140 | ((char= c #\v) ; equiv: %e-%b-%Y 141 | (let ((date (read-fixed-time (make-string-input-stream "%e-%b-%Y") 142 | str))) 143 | (setf year (nth 5 date) 144 | month (nth 4 date) 145 | day (nth 3 date)))) 146 | 147 | ((char= c #\W)) ; week number of the year (Mon) 00-53 148 | ((char= c #\w)) ; weekday as a decimal (Sun) 0-6 149 | ;;((char= c #\X)) ; national representation of the time 150 | ;;((char= c #\x)) ; national representation of the date 151 | 152 | ((char= c #\Y) 153 | (setf year (read-integer str 4))) 154 | 155 | ((char= c #\y) 156 | (setf year (read-integer str 2)) 157 | (if (< year 70) 158 | (incf year 2000) 159 | (incf year 1900))) 160 | 161 | ((char= c #\Z)) ; time zone name 162 | ((char= c #\z)) ; time zone offset from UTC 163 | ;;((char= c #\+)) ; national representation of date/time 164 | 165 | ((char= c #\|) ; abort if string is ended 166 | (if (null next) 167 | (return))))) 168 | 169 | (if (char= c next) 170 | (read-char str) 171 | (error "Expected '~C', got '~C'" c next)))) 172 | (list 0 second minute hour day month year))) 173 | 174 | (defun strptime-decoded (string &key (format *input-time-format*)) 175 | (with-input-from-string (in format) 176 | (with-input-from-string (str string) 177 | (read-fixed-time str in)))) 178 | 179 | (defun strptime (string &key format default-year) 180 | (let ((decoded (strptime-decoded string 181 | :format (or format *input-time-format*)))) 182 | (unless (nth 6 decoded) 183 | (setf (nth 6 decoded) (or default-year (current-year)))) 184 | (apply #'encode-timestamp decoded))) 185 | 186 | (defun strftime (fixed-time &key (format *output-time-format*)) 187 | (declare (type fixed-time fixed-time)) 188 | (declare (type string format)) 189 | (multiple-value-bind 190 | (millisecond second minute hour day month year day-of-week 191 | daylight-p time-zone time-zone-abbrev) 192 | (local-time:decode-timestamp fixed-time) 193 | (declare (ignore millisecond)) 194 | (declare (ignorable day-of-week)) 195 | (declare (ignorable daylight-p)) 196 | (with-output-to-string (out) 197 | (with-input-from-string (in format) 198 | (loop 199 | for c = (read-char in nil) 200 | while c 201 | do 202 | (if (char= c #\%) ; specifier 203 | (progn 204 | (setf c (read-char in)) 205 | (cond 206 | ((char= c #\%) 207 | (write-char #\% out)) 208 | 209 | ((char= c #\A)) ; full weekday name 210 | ((char= c #\a)) ; abbreviated weekday name 211 | 212 | ((char= c #\B)) ; full month name 213 | ((or (char= c #\b) ; abbreviated month name 214 | (char= c #\h))) ; same as %b 215 | 216 | ((char= c #\C) ; century, zero prefix 217 | (format out "~2,'0D" (floor year 100))) 218 | 219 | ;;((char= c #\c)) ; national representation of date/time 220 | 221 | ((char= c #\D) ; equiv: %m/%d/%y 222 | (princ (strftime fixed-time :format "%m/%d/%y") out)) 223 | 224 | ((char= c #\d) 225 | (format out "~2,'0D" day)) 226 | ((char= c #\e) ; day of month, space prefix 227 | (format out "~2,' D" day)) 228 | 229 | ;;((char= c #\E)) ; POSIX locale extensions 230 | ;;((char= c #\O)) 231 | 232 | ((char= c #\F) ; equiv: %Y-%m-%d 233 | (princ (strftime fixed-time :format "%Y-%m-%d") out)) 234 | ; 235 | ((char= c #\G)) ; year as a decimal number with century 236 | ((char= c #\g)) ; same as %G, without century 237 | 238 | ((char= c #\H) ; hour, zero prefix 239 | (format out "~2,'0D" hour)) 240 | ((char= c #\I) ; hour on the 12-hour clock 241 | (if (> hour 12) 242 | (format out "~2,'0D" (- hour 12)) 243 | (if (= hour 0) 244 | (format out "~2,'0D" 12) 245 | (format out "~2,'0D" hour)))) 246 | 247 | ((char= c #\k) ; hour, space prefix 248 | (format out "~2,' D" hour)) 249 | ((char= c #\l) ; 12-hour hour, space prefix 250 | (if (> hour 12) 251 | (format out "~2,' D" (- hour 12)) 252 | (if (= hour 0) 253 | (format out "~2,' D" 12) 254 | (format out "~2,' D" hour)))) 255 | 256 | ((char= c #\j)) ; day of the year as a decimal 257 | 258 | ((char= c #\M) 259 | (format out "~2,'0D" minute)) 260 | 261 | ((char= c #\m) 262 | (format out "~2,'0D" month)) 263 | 264 | ((char= c #\p)) ; national AM/PM, as appropriate 265 | 266 | ((char= c #\R) ; equiv: %H:%M 267 | (princ (strftime fixed-time :format "%H:%M") out)) 268 | 269 | ((char= c #\r) ; equiv: %I:%M:%S %p 270 | (princ (strftime fixed-time :format "%I:%M:%S %p") out)) 271 | 272 | ((char= c #\S) 273 | (format out "~2,'0D" second)) 274 | 275 | ((char= c #\s) ; seconds since Epoch, UTC (unix time) 276 | (format out "~D" (local-time:timestamp-to-unix fixed-time))) 277 | 278 | ((char= c #\T) ; equiv: %H:%M:%S 279 | (princ (strftime fixed-time :format "%H:%M:%S") out)) 280 | 281 | ((char= c #\t) ; tab 282 | (write-char #\Tab out)) 283 | 284 | ((char= c #\U)) ; week number of the year (Sun) 00-53 285 | ((char= c #\u)) ; weekday as a decimal (Mon) 1-7 286 | ((char= c #\V)) ; week of the year 1-53 (*) 287 | 288 | ((char= c #\v) ; equiv: %e-%b-%Y 289 | (princ (strftime fixed-time :format "%e-%b-%Y") out)) 290 | 291 | ((char= c #\W)) ; week number of the year (Mon) 00-53 292 | ((char= c #\w)) ; weekday as a decimal (Sun) 0-6 293 | ;;((char= c #\X)) ; national representation of the time 294 | ;;((char= c #\x)) ; national representation of the date 295 | 296 | ((char= c #\Y) 297 | (format out "~4,'0D" year)) 298 | ((char= c #\y) 299 | (format out "~4,'0D" (floor year 100))) 300 | 301 | ((char= c #\Z) ; time zone name 302 | (format out "~A" time-zone-abbrev)) 303 | ((char= c #\z) ; time zone offset from UTC 304 | (format out "~D" time-zone)) 305 | ;;((char= c #\+)) ; national representation of date/time 306 | 307 | ((char= c #\|) ; abort if string is ended 308 | (if (and (zerop (sec-of fixed-time)) 309 | (zerop (nsec-of fixed-time))) 310 | (return))))) 311 | 312 | (write-char c out))))))) 313 | 314 | (provide 'strptime) 315 | 316 | ;; strptime.lisp ends here 317 | --------------------------------------------------------------------------------