From 4d80dbab1a3826b8bcbbbc7ad28318bed0fc801b Mon Sep 17 00:00:00 2001 From: Camm Maguire Date: Sun, 25 Dec 2022 12:14:33 +0000 Subject: [PATCH] TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. gcl (2.6.13-3) unstable; urgency=medium * Version_2_6_14pre2 Gbp-Pq: Name Version_2_6_14pre2 --- git.tag | 2 +- lsp/gcl_mislib.lsp | 78 +++++++++------------------------------ o/unixtime.c | 80 ++++++++++++++++++++++++++++++++++++++++ unixport/sys_init.lsp.in | 2 +- 4 files changed, 99 insertions(+), 63 deletions(-) diff --git a/git.tag b/git.tag index b9b4539..d56e241 100644 --- a/git.tag +++ b/git.tag @@ -1,2 +1,2 @@ -"Version_2_6_14pre1" +"Version_2_6_14pre2" diff --git a/lsp/gcl_mislib.lsp b/lsp/gcl_mislib.lsp index 70d84ef..c564c0c 100755 --- a/lsp/gcl_mislib.lsp +++ b/lsp/gcl_mislib.lsp @@ -50,77 +50,33 @@ (/ ,gbc-time internal-time-units-per-second)))) (values-list ,x)))) -(defconstant seconds-per-day #.(* 24 3600)) - -(defun leap-year-p (y) - (and (zerop (mod y 4)) - (or (not (zerop (mod y 100))) (zerop (mod y 400))))) - -(defun number-of-days-from-1900 (y) - (let ((y1 (1- y))) - (+ (* (- y 1900) 365) - (floor y1 4) (- (floor y1 100)) (floor y1 400) - -460))) - -(eval-when - (compile eval) - (defmacro mmd (n &optional lp - &aux (l '(31 28 31 30 31 30 31 31 30 31 30 31)) - (l (if lp (cons (pop l) (cons (1+ (pop l)) l)) l))(r 0)(s (mapcar (lambda (x) (incf r x)) l))) - `(defconstant ,n (make-array ,(length s) :element-type '(integer ,(car s) ,(car (last s))) :initial-contents ',s)))) - -(mmd +md+) -(mmd +lmd+ t) - -(defun decode-universal-time (ut &optional (tz (let ((x (current-timezone))) (if (current-dstp) (1+ x) x)) tzp) - &aux (out ut)(ut (- ut (* tz 3600)))) + +(defun this-tz (&aux (x (current-timezone))) + (if (current-dstp) (1+ x) x)) + +(defun decode-universal-time (ut &optional (tz (this-tz) tzp)) (declare (optimize (safety 2))) (check-type ut integer) (check-type tz rational) + (let ((ut (+ ut (* (- (this-tz) tz) 3600) #.(* -1 (+ 17 (* 70 365)) 24 60 60)))) (multiple-value-bind - (d ut) (floor ut seconds-per-day) - (let* ((dow (mod d 7))(y (+ 1900 (floor d 366)))) - (labels ((l (y dd &aux (lyp (leap-year-p y))(td (if lyp 366 365))(x (- d dd))) - (if (< x td) (values (1+ x) y lyp) (l (1+ y) (+ dd td))))) - (multiple-value-bind - (d y lyp) (l y (number-of-days-from-1900 y)) - (let* ((l (if lyp +lmd+ +md+)) - (m (position d l :test '<=)) - (d (if (> m 0) (- d (aref l (1- m))) d))) - (multiple-value-bind - (h ut) (floor ut 3600) - (labels ((nsdom (d dow n) (+ (mod (- d dow 1) 7) (* (1- n) 7))) - (dstp (dow d m h) - (cond ((> 10 m 2)) - ((eql m 2) (let ((s (nsdom d dow 2))) (or (> d s) (when (= d s) (>= h 2))))) - ((eql m 10) (let ((s (nsdom d dow 1))) (or (< d s) (when (= d s) (< h 1)))))))) - (if (unless tzp (dstp dow d m h)) - (multiple-value-bind - (s m h d o y w) (decode-universal-time out (1- tz)) - (values s m h d o y w t tz)) - (multiple-value-bind - (min sec) (floor ut 60) - (values sec min h d (1+ m) y dow nil tz))))))))))) - -(defun encode-universal-time (sec min h d m y &optional (tz (let ((x (current-timezone))) (if (current-dstp) (1+ x) x)))) + (s n h d m y w yd dstp off) (localtime ut) + (when (when tzp (> dstp 0)) + (multiple-value-setq (s n h d m y w yd) (localtime (- ut 3600)))) + (values s n h d (1+ m) (+ 1900 y) (1- w) (unless tzp (> dstp 0)) (if tzp tz (+ (truncate (- off) 3600) dstp)))))) + +(defun encode-universal-time (s n h d m y &optional (tz (this-tz) tzp)) (declare (optimize (safety 2))) - (check-type sec (integer 0 59)) - (check-type min (integer 0 59)) + (check-type s (integer 0 59)) + (check-type n (integer 0 59)) (check-type h (integer 0 23)) (check-type d (integer 1 31)) (check-type m (integer 1 12)) (check-type y integer) (check-type tz rational) - (when (<= 0 y 99) - (multiple-value-bind - (sec min h d m y1 dow dstp tz) (get-decoded-time) - (declare (ignore sec min h d m dow dstp tz)) - (incf y (- y1 (mod y1 100))) - (cond ((< (- y y1) -50) (incf y 100)) - ((>= (- y y1) 50) (decf y 100))))) - (+ (* (+ (1- d) (number-of-days-from-1900 y) (if (> m 1) (aref (if (leap-year-p y) +lmd+ +md+) (- m 2)) 0)) - seconds-per-day) - (* (+ h tz) 3600) (* min 60) sec)) + (multiple-value-bind + (tm dstp) (mktime s n h d (1- m) (- y 1900)) + (+ tm #.(* (+ 17 (* 70 365)) 24 60 60) (* (- tz (this-tz)) 3600) (if tzp (* dstp 3600) 0)))) (defun compile-file-pathname (pathname) (make-pathname :defaults pathname :type "o")) diff --git a/o/unixtime.c b/o/unixtime.c index 3be590d..e265ef2 100755 --- a/o/unixtime.c +++ b/o/unixtime.c @@ -302,3 +302,83 @@ DEFUN_NEW("CURRENT-DSTP",object,fScurrent_dstp,SI,0,0,NONE,OO,OO,OO,OO,(void),"" return localtime(&_t)->tm_isdst > 0 ? Ct : Cnil; #endif } + +DEFUNM_NEW("LOCALTIME",object,fSlocaltime,SI,1,1,NONE,OI,OO,OO,OO,(fixnum t),"") { + +#if defined NO_SYSTEM_TIME_ZONE /*solaris*/ + return Cnil; +#else + +#if defined(__MINGW32__) + fixnum gmt_hour=gmtime(&t)->tm_hour; +#endif + struct tm *lt=localtime(&t); + + RETURN(11,object, + make_fixnum(lt->tm_sec), + ( + RV(make_fixnum(lt->tm_min)), + RV(make_fixnum(lt->tm_hour)), + RV(make_fixnum(lt->tm_mday)), + RV(make_fixnum(lt->tm_mon)), + RV(make_fixnum(lt->tm_year)), + RV(make_fixnum(lt->tm_wday)), + RV(make_fixnum(lt->tm_yday)), + RV(make_fixnum(lt->tm_isdst)), +#if defined(__MINGW32__) + RV(make_fixnum((lt->tm_hour-gmt_hour)*3600)), + RV(Cnil) +#else + RV(make_fixnum(lt->tm_gmtoff)), + RV(make_simple_string(lt->tm_zone)) +#endif + )); +#endif +} + + +DEFUNM_NEW("GMTIME",object,fSgmtime,SI,1,1,NONE,OI,OO,OO,OO,(fixnum t),"") { + +#if defined NO_SYSTEM_TIME_ZONE /*solaris*/ + return Cnil; +#else + struct tm *lt=gmtime(&t); + RETURN(11,object, + make_fixnum(lt->tm_sec), + ( + RV(make_fixnum(lt->tm_min)), + RV(make_fixnum(lt->tm_hour)), + RV(make_fixnum(lt->tm_mday)), + RV(make_fixnum(lt->tm_mon)), + RV(make_fixnum(lt->tm_year)), + RV(make_fixnum(lt->tm_wday)), + RV(make_fixnum(lt->tm_yday)), + RV(make_fixnum(lt->tm_isdst)), +#if defined(__MINGW32__) + RV(make_fixnum(0)), + RV(Cnil) +#else + RV(make_fixnum(lt->tm_gmtoff)), + RV(make_simple_string(lt->tm_zone)) +#endif + )); +#endif +} + + +DEFUNM_NEW("MKTIME",object,fSmktime,SI,6,6,NONE,OI,II,II,IO,(fixnum s,fixnum n,fixnum h,fixnum d,fixnum m,fixnum y),"") { + + struct tm lt; + + lt.tm_sec=s; + lt.tm_min=n; + lt.tm_hour=h; + lt.tm_mday=d; + lt.tm_mon=m; + lt.tm_year=y; + lt.tm_isdst=-1; + + RETURN(2,object,make_fixnum(mktime(<)),(RV(make_fixnum(lt.tm_isdst)))); + +} + diff --git a/unixport/sys_init.lsp.in b/unixport/sys_init.lsp.in index ce41b9b..c1facec 100644 --- a/unixport/sys_init.lsp.in +++ b/unixport/sys_init.lsp.in @@ -82,7 +82,7 @@ #+ansi-cl (use-package :pcl :user) (import 'si::(clines defentry defcfun object void int double quit bye gbc system - *lib-directory* *system-directory* while) :user) + *lib-directory* *system-directory* while help) :user) (let* ((i 4096)(j (si::equal-tail-recursion-check i))) (unless (<= (ash i -1) j) -- 2.30.2