; .EnTete "Le-Lisp (c) version 15.2" " " "La date"
; .EnPied " " "%" " "
; .SuperTitre "La date de base"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: date.ll,v 4.3 88/11/25 11:52:06 gallou Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'date))
(defvar #:sys-package:colon 'date)
(add-feature 'date)
; Ajout de ces cinq de'finitions re'cupe're'es dans libdate afin d'e'viter
; d'importer ce dernier module en entier.
; Calcul du nume'ro (1-7) du jour de la semaine (Gre'gorien, year >= 0)
(de week-day-number (date)
(ifn (datep date) (error 'week-day-number 'errbpa date))
(let ((year (:year date))(month (:month date))
(day (:day date))(result 5))
; le premier janvier 0 etait un samedi
(setq result
(+ result year
(leap-number year)
(year-day-number date)))
(setq result (modulo result 7))
(if (eq result 0) 7 result)))
; Calcul du nume'ro du jour dans l'anne'e
(de year-day-number (date)
(ifn (datep date) (error 'year-day-number 'errbpa date))
(let ((year (:year date))(month (:month date))(day (:day date)))
(if (> month 1)
(for (i 1 1 (1- month)) (incr day (month-length i year))))
day))
(de month-length (month year)
(+ (cassq month month-lengths)
(if (and (eq month 2) (leap-year-p year)) 1 0)))
; Le pre'dicat des anne'es bissextiles
(de leap-year-p (year)
(if (eq (modulo year 4) 0)
(if (eq (modulo year 100) 0) (eq (modulo year 400) 0) t)))
; Le nombre d'anne'es bissextiles depuis l'an 0
(de leap-number (year)
(let ((previous (if (> year 0) (1- year) year)))
(+ (div previous 4)
(- (div previous 100))
(div previous 400)
(if (> year 0) 1 0))))
; .Section "Interface"
(unless (getdef 'create-date)
(defstruct date
year month day hour minute second msecond week-day))
(de create-date ()
; cre' une date : ve'rifie la re'ponse du syste`me et
; charge les options par de'faut.
(let ((date (date)))
(typevector date 'date)
(unless (fixp (:year date))
(error 'date
#- #:system:foreign-language "mauvaise annee"
#+ #:system:foreign-language "bad year"
date))
(when (or (not (fixp (:month date)))
(< (:month date) 1) (> (:month date) 12))
(error 'date
#- #:system:foreign-language "mauvais mois"
#+ #:system:foreign-language "bad month"
date))
(when (or (not (fixp (:day date)))
(< (:day date) 1) (> (:day date) 31))
(error 'date
#- #:system:foreign-language "mauvais jour"
#+ #:system:foreign-language "bad day"
date))
(when (or (not (fixp (:hour date)))
(< (:hour date) 0) (> (:hour date) 23))
(error 'date
#- #:system:foreign-language "mauvaise heure"
#+ #:system:foreign-language "bad hour"
date))
(when (or (not (fixp (:minute date)))
(< (:minute date) 0) (> (:minute date) 59))
(error 'date
#- #:system:foreign-language "mauvaise minute"
#+ #:system:foreign-language "bad minute"
date))
(unless (:second date) (:second date 0))
(when (or (not (fixp (:second date)))
(< (:second date) 0) (> (:second date) 59))
(error 'date
#- #:system:foreign-language "mauvaise seconde"
#+ #:system:foreign-language "bad second"
date))
(unless (:msecond date) (:msecond date 0))
(when (or (not (fixp (:msecond date)))
(< (:msecond date) 0) (> (:msecond date) 999))
(error 'date
#- #:system:foreign-language "mauvaise mseconde"
#+ #:system:foreign-language "bad millisecond"
date))
(unless (:week-day date)
(:week-day date (week-day-number date)))
(when (or (not (fixp (:week-day date)))
(< (:week-day date) 1) (> (:week-day date) 7))
(error 'date
#- #:system:foreign-language "mauvaise week-day"
#+ #:system:foreign-language "bad day of the week"
date))
date))
(de #:date:prin (date)
; impression de la structure "date"
(if #:system:print-for-read
(let ((#:system:print-for-read ()))
(prin "#:date:#["
(:year date) " "
(:month date) " "
(:day date) " "
(:hour date) " "
(:minute date) " "
(:second date) " "
(:msecond date) " "
(:week-day date) "]"))
(prin (short-string-date date))))
; .Section "Les donne'es"
;
; De'but de la partie de'pendante du site
; A chaque fois, on a les versions courtes et longues
; Les noms des mois
#- #:system:foreign-language
(defvar short-month-names '((1 . "janv")(2 . "fevr")(3 . "mars")
(4 . "avr")(5 . "mai")(6 . "juin")(7 . "juil")(8 . "aout")
(9 . "sept")(10 . "oct")(11 . "nov")(12 . "dec")))
#+ #:system:foreign-language
(defvar short-month-names '((1 . "jan")(2 . "feb")(3 . "mar")
(4 . "apr")(5 . "may")(6 . "june")(7 . "july")(8 . "aug")
(9 . "sept")(10 . "oct")(11 . "nov")(12 . "dec")))
; Les noms des jours
#- #:system:foreign-language
(defvar short-day-names '((1 . "lun")(2 . "mar")(3 . "mer")(4 . "jeu")
(5 . "ven")(6 . "sam")(7 . "dim")))
#+ #:system:foreign-language
(defvar short-day-names '((1 . "mon")(2 . "tue")(3 . "wed")(4 . "thu")
(5 . "fri")(6 . "sat")(7 . "sun")))
; Fin des donne'es de'pendantes du site
; La longueur des mois
(defvar month-lengths '((1 . 31)(2 . 28)(3 . 31)(4 . 30)(5 . 31)
(6 . 30)(7 . 31)(8 . 31)(9 . 30)(10 . 31)(11 . 30)(12 . 31)))
; .Section "Les conversions"
; le format court (24 caracte`res)
(de short-string-date (date)
(ifn (datep date) (error 'short-string-date 'errbpa date))
(let ((year (modulo (:year date) 100))
(month-name (cassq (:month date) short-month-names))
(day (:day date))(hour (:hour date))
(min (:minute date))(sec (:second date))
(day-name (cassq (:week-day date) short-day-names))
(result (makestring 24 #\sp)))
#- #:system:foreign-language
(progn
(bltstring result 0 day-name 0)
(bltstring result (- 6 (slength day)) day 0)
(bltstring result 7 month-name 0))
#+ #:system:foreign-language
(progn
(bltstring result 0 day-name 0)
(bltstring result (- 11 (slength day)) day 0)
(bltstring result 4 month-name 0))
(bltstring result (- 14 (slength year)) year 0)
(bltstring result 15 "00:00:00" 0)
(bltstring result (- 17 (slength hour)) hour 0)
(bltstring result (- 20 (slength min)) min 0)
(bltstring result (- 23 (slength sec)) sec 0)
result))
; .Section "Les utilitaires"
; Le pre'dicat : est une date
(de datep (date)
(and (vectorp date) (eq (typevector date) 'date)))