From e9927af19ebf762b2311f296643c00e3aa9cbb00 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 2 Jul 2004 17:02:42 +0000 Subject: [PATCH] r9728: updates --- debian/changelog | 6 +++ io.lisp | 109 ++++++++++++++++++++++++++++++++++++++++++++++- package.lisp | 25 ++++++++++- strings.lisp | 6 +-- 4 files changed, 141 insertions(+), 5 deletions(-) diff --git a/debian/changelog b/debian/changelog index 3429a8d..da896b8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-kmrcl (1.76-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Mon, 28 Jun 2004 11:24:57 -0600 + cl-kmrcl (1.75-1) unstable; urgency=low * New upstream diff --git a/io.lisp b/io.lisp index db94854..61298ad 100644 --- a/io.lisp +++ b/io.lisp @@ -219,4 +219,111 @@ (list root) (error "root not directory ~A" root))))) - + +(defmacro with-utime-decoding ((utime &optional zone) &body body) + "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time. Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time" + `(multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time ,utime ,@(if zone (list zone))) + (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) + ,@body)) + +(defvar +datetime-number-strings+ + (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil + :initial-contents + '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11" + "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23" + "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35" + "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47" + "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59" + "60"))) + +(defun is-dst (utime) + (with-utime-decoding (utime) + daylight-p)) + + +(defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body) + (with-gensyms (zone) + `(let* ((,zone (cond + ((eq :utc ,utc-offset) + 0) + ((null utc-offset) + nil) + (t + (if (is-dst ,utime) + (1- (- ,utc-offset)) + (- ,utc-offset)))))) + (if ,zone + (with-utime-decoding (,utime ,zone) + ,@body) + (with-utime-decoding (,utime) + ,@body))))) + + +(defun write-utime-hms (utime &key utc-offset stream) + (if stream + (write-utime-hms-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-hms-stream utime s utc-offset)))) + +(defun write-utime-hms-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ second) stream))) + +(defun write-utime-hm (utime &key utc-offset stream) + (if stream + (write-utime-hm-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-hm-stream utime s utc-offset)))) + +(defun write-utime-hm-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream))) + + +(defun write-utime-ymdhms (utime &key stream utc-offset) + (if stream + (write-utime-ymdhms-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-ymdhms-stream utime s utc-offset)))) + +(defun write-utime-ymdhms-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (prefixed-fixnum-string year nil 4) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ month) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ day-of-month) stream) + (write-char #\space stream) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ second) stream))) + +(defun write-utime-ymdhm (utime &key stream utc-offset) + (if stream + (write-utime-ymdhm-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-ymdhm-stream utime s utc-offset)))) + +(defun write-utime-ymdhm-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (prefixed-fixnum-string year nil 4) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ month) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ day-of-month) stream) + (write-char #\space stream) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream))) + + diff --git a/package.lisp b/package.lisp index 8bb206b..64db28f 100644 --- a/package.lisp +++ b/package.lisp @@ -85,7 +85,30 @@ #:stream-subst #:null-output-stream #:directory-tree - + #:write-utime-hms + #:write-utime-hm + #:write-utime-ymdhms + #:write-utime-ymdhm + #:write-utime-hms-stream + #:write-utime-hm-stream + #:write-utime-ymdhms-stream + #:write-utime-ymdhm-stream + #:with-utime-decoding + #:with-utime-decoding-utc-offset + #:is-dst + #:year + #:month + #:day-of-month + #:hour + #:minute + #:second + #:daylight-p + #:zone + #:day-of-month + #:day-of-week + #:+datetime-number-strings+ + #:utc-offset + ;; impl.lisp #:probe-directory #:cwd diff --git a/strings.lisp b/strings.lisp index 8201a98..9dbe1ba 100644 --- a/strings.lisp +++ b/strings.lisp @@ -413,9 +413,9 @@ for characters in a string" (declare (type (integer 0 15) n)) (schar +hex-chars+ n)) -(defconstant +char-code-lower-a+ (char-code #\a)) -(defconstant +char-code-upper-a+ (char-code #\A)) -(defconstant +char-code-0+ (char-code #\0)) +(defconst +char-code-lower-a+ (char-code #\a)) +(defconst +char-code-upper-a+ (char-code #\A)) +(defconst +char-code-0+ (char-code #\0)) (declaim (type fixnum +char-code-0+ +char-code-upper-a+ +char-code-0)) -- 2.34.1