home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / defs1.lsp < prev    next >
Text File  |  1996-04-15  |  28KB  |  720 lines
  1. ;;;; Einige Definitionen von Standard-Funktionen in LISP
  2. ;;;; 1.8.1989, 2.9.1989, 8.10.1989
  3.  
  4. (in-package "LISP")
  5. (export '(doseq dohash #-(or UNIX WIN32-UNIX) *default-time-zone* default-directory dir))
  6. (in-package "SYSTEM")
  7.  
  8.  
  9. ;;; Funktionen für Symbole (Kapitel 10)
  10.  
  11. (defun copy-symbol (symbol &optional flag)
  12.                    ;; Common LISP, S. 169
  13.   (let ((sym (make-symbol (symbol-name symbol))))
  14.     (when flag
  15.       (when (boundp symbol) (set sym (%symbol-value symbol)))
  16.       (when (fboundp symbol) (sys::%putd sym (symbol-function symbol)))
  17.       (sys::%putplist sym (copy-list (symbol-plist symbol)))
  18.     )
  19.     sym
  20. ) )
  21.  
  22. (let ((gentemp-count 0))
  23.   (defun gentemp (&optional (prefix "T") (package *package*))
  24.                  ;; Common LISP, S. 170
  25.     (loop
  26.       (setq gentemp-count (1+ gentemp-count))
  27.       (multiple-value-bind (sym flag)
  28.         (intern
  29.           (string-concat prefix
  30.             (write-to-string gentemp-count :base 10 :radix nil :readably nil)
  31.           )
  32.           package
  33.         )
  34.         (unless flag (return sym))
  35. ) ) ) )
  36.  
  37.  
  38. ;;; Macros für Packages (Kapitel 11), S. 187-188
  39.  
  40. (defmacro do-symbols ((var &optional (packageform '*package*) (resultform nil))
  41.                       &body body &environment env)
  42.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  43.     (let ((packvar (gensym)))
  44.       `(BLOCK NIL
  45.          (LET ((,packvar ,packageform))
  46.            (LET ((,var NIL))
  47.              (DECLARE (IGNORABLE ,var) ,@declarations)
  48.              (SYSTEM::MAP-SYMBOLS
  49.                #'(LAMBDA (,var)
  50.                    ,@(if declarations `((DECLARE ,@declarations)) '())
  51.                    ,@body-rest
  52.                  )
  53.                ,packvar
  54.              )
  55.              ,resultform
  56.        ) ) )
  57. ) ) )
  58.  
  59. (defmacro do-external-symbols ((var &optional (packageform '*package*) (resultform nil))
  60.                                &body body &environment env)
  61.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  62.     (let ((packvar (gensym)))
  63.       `(BLOCK NIL
  64.          (LET ((,packvar ,packageform))
  65.            (LET ((,var NIL))
  66.              (DECLARE (IGNORABLE ,var) ,@declarations)
  67.              (SYSTEM::MAP-EXTERNAL-SYMBOLS
  68.                #'(LAMBDA (,var)
  69.                    ,@(if declarations `((DECLARE ,@declarations)) '())
  70.                    ,@body-rest
  71.                  )
  72.                ,packvar
  73.              )
  74.              ,resultform
  75.        ) ) )
  76. ) ) )
  77.  
  78. (defmacro do-all-symbols ((var &optional (resultform nil))
  79.                           &body body &environment env)
  80.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  81.     `(BLOCK NIL
  82.        (LET ((,var NIL))
  83.          (DECLARE (IGNORABLE ,var) ,@declarations)
  84.          (SYSTEM::MAP-ALL-SYMBOLS
  85.            #'(LAMBDA (,var)
  86.                ,@(if declarations `((DECLARE ,@declarations)) '())
  87.                ,@body-rest
  88.              )
  89.          )
  90.          ,resultform
  91.      ) )
  92. ) )
  93.  
  94. ;;; Modulverwaltung (Kapitel 11.8), CLTL S. 188
  95.  
  96. (defvar *modules* nil)
  97.  
  98. (defun provide (module-name)
  99.   (setq *modules* (adjoin (string module-name) *modules* :test #'string=))
  100. )
  101.  
  102. (defun require (module-name &optional (pathname nil p-given))
  103.   (unless (member (string module-name) *modules* :test #'string-equal)
  104.     (unless p-given (setq pathname (pathname module-name)))
  105.     (let (#-CLISP(*default-pathname-defaults* '#""))
  106.       (if (atom pathname) (load pathname) (mapcar #'load pathname))
  107.     )
  108. ) )
  109.  
  110.  
  111. ;;; Konstanten für Zahlen (Kapitel 12)
  112.  
  113. ; vgl. File INTLOG.TXT
  114. (defconstant boole-clr 0)
  115. (defconstant boole-set 15)
  116. (defconstant boole-1 10)
  117. (defconstant boole-2 12)
  118. (defconstant boole-c1 5)
  119. (defconstant boole-c2 3)
  120. (defconstant boole-and 8)
  121. (defconstant boole-ior 14)
  122. (defconstant boole-xor 6)
  123. (defconstant boole-eqv 9)
  124. (defconstant boole-nand 7)
  125. (defconstant boole-nor 1)
  126. (defconstant boole-andc1 4)
  127. (defconstant boole-andc2 2)
  128. (defconstant boole-orc1 13)
  129. (defconstant boole-orc2 11)
  130.  
  131. ; Zum Wiedereinlesen von BYTEs:
  132. (defun make-byte (&key size position) (byte size position))
  133.  
  134. ; X3J13 vote <79>
  135. (defconstant least-positive-normalized-short-float least-positive-short-float)
  136. (defconstant least-negative-normalized-short-float least-negative-short-float)
  137. (defconstant least-positive-normalized-single-float least-positive-single-float)
  138. (defconstant least-negative-normalized-single-float least-negative-single-float)
  139. (defconstant least-positive-normalized-double-float least-positive-double-float)
  140. (defconstant least-negative-normalized-double-float least-negative-double-float)
  141. (defconstant least-positive-normalized-long-float least-positive-long-float)
  142. (defconstant least-negative-normalized-long-float least-negative-long-float)
  143.  
  144.  
  145. ;;; Konstanten für Zeichen (Kapitel 13)
  146.  
  147. (defconstant char-code-limit 256)
  148. (defconstant char-font-limit 16)
  149. (defconstant char-bits-limit 16)
  150.                    ;; Common LISP, S. 233, 234
  151.  
  152. (defconstant char-control-bit 1)
  153. (defconstant char-meta-bit 2)
  154. (defconstant char-super-bit 4)
  155. (defconstant char-hyper-bit 8)
  156.                    ;; Common LISP, S. 243
  157.  
  158.  
  159. ;;; Funktionen für Sequences (Kapitel 14)
  160.  
  161. (defmacro doseq ((var seqform &optional resultform) &body body &environment env)
  162.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  163.     (let ((seqvar (gensym)))
  164.       `(BLOCK NIL
  165.          (LET ((,seqvar ,seqform))
  166.            (LET ((,var NIL))
  167.              (DECLARE (IGNORABLE ,var) ,@declarations)
  168.              (MAP NIL
  169.                   #'(LAMBDA (,var)
  170.                       ,@(if declarations `((DECLARE ,@declarations)) '())
  171.                       (TAGBODY ,@body-rest)
  172.                     )
  173.                   ,seqvar
  174.              )
  175.              ,resultform
  176.        ) ) )
  177. ) ) )
  178.  
  179.  
  180. ;;; Funktionen für Listen (Kapitel 15)
  181.  
  182. ; Hilfsversion von MEMBER, die das :KEY-Argument auch auf item anwendet:
  183. (defun sys::member1 (item list &rest rest &key test test-not key)
  184.   (declare (ignore test test-not))
  185.   (unless key (setq key #'identity))
  186.   (apply #'member (funcall key item) list rest)
  187. )
  188.  
  189. (defun union (list1 list2 &rest rest &key test test-not key)
  190.   (declare (ignore test test-not key))
  191.   (cond ((endp list1) list2)
  192.         ((apply #'sys::member1 (car list1) list2 rest)
  193.          (apply #'union (cdr list1) list2 rest))
  194.         (t (cons (car list1) (apply #'union (cdr list1) list2 rest)))
  195. ) )
  196.  
  197. (defun nunion (list1 list2 &rest rest &key test test-not key)
  198.   (declare (ignore test test-not key))
  199.   (cond ((endp list1) list2)
  200.         ((apply #'sys::member1 (car list1) list2 rest)
  201.          (apply #'nunion (cdr list1) list2 rest))
  202.         (t (rplacd list1 (apply #'nunion (cdr list1) list2 rest)))
  203. ) )
  204.  
  205. (defun intersection (list1 list2 &rest rest &key test test-not key)
  206.   (declare (ignore test test-not key))
  207.   (cond ((endp list1) nil)
  208.         ((apply #'sys::member1 (car list1) list2 rest)
  209.          (cons (car list1)
  210.                (apply #'intersection (cdr list1) list2 rest)))
  211.         (t (apply #'intersection (cdr list1) list2 rest))
  212. ) )
  213.  
  214. (defun nintersection (list1 list2 &rest rest &key test test-not key)
  215.   (declare (ignore test test-not key))
  216.   (cond ((endp list1) nil)
  217.         ((apply #'sys::member1 (car list1) list2 rest)
  218.          (rplacd list1 (apply #'nintersection (cdr list1) list2 rest)) )
  219.         (t (apply #'nintersection (cdr list1) list2 rest))
  220. ) )
  221.  
  222. (defun set-difference (list1 list2 &rest rest &key test test-not key)
  223.   (declare (ignore test test-not key))
  224.   (cond ((endp list1) nil)
  225.         ((not (apply #'sys::member1 (car list1) list2 rest))
  226.          (cons (car list1)
  227.                (apply #'set-difference (cdr list1) list2 rest)
  228.         ))
  229.         (t (apply #'set-difference (cdr list1) list2 rest))
  230. ) )
  231.  
  232. (defun nset-difference (list1 list2 &rest rest &key test test-not key)
  233.   (declare (ignore test test-not key))
  234.   (cond ((endp list1) nil)
  235.         ((not (apply #'sys::member1 (car list1) list2 rest))
  236.          (rplacd list1 (apply #'nset-difference (cdr list1) list2 rest)) )
  237.         (t (apply #'nset-difference (cdr list1) list2 rest))
  238. ) )
  239.  
  240. (defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)
  241.   (declare (ignore test test-not key))
  242.   (append (apply #'set-difference list1 list2 rest)
  243.           (apply #'set-difference list2 list1 rest)
  244. ) )
  245.  
  246. (defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)
  247.   (declare (ignore test test-not key))
  248.   (nconc (apply #'set-difference list1 list2 rest)
  249.          (apply #'nset-difference list2 list1 rest)
  250. ) )
  251.  
  252. (defun subsetp (list1 list2 &rest rest &key test test-not key)
  253.   (declare (ignore test test-not key))
  254.   (do ((l list1 (cdr l)))
  255.       ((endp l) t)
  256.     (if (not (apply #'sys::member1 (car l) list2 rest)) (return nil))
  257. ) )
  258.  
  259. ; Wie SUBST-IF, nur daß das Ersatz-Element durch eine Funktion gegeben wird
  260. ; und nicht konstant sein muß.
  261. (defun subst-if-then (newfun testfun tree &key (key #'identity))
  262.   (labels ((subst (tree)
  263.              (if (funcall testfun (funcall key tree))
  264.                (funcall newfun tree)
  265.                (if (consp tree)
  266.                  (let* ((car (car tree)) (cdr (cdr tree))
  267.                         (newcar (subst car)) (newcdr (subst cdr)))
  268.                    (if (and (eq car newcar) (eq cdr newcdr))
  269.                      tree
  270.                      (cons newcar newcdr)
  271.                  ) )
  272.                  tree
  273.           )) ) )
  274.     (subst tree)
  275. ) )
  276.  
  277.  
  278. ;;; Funktionen für Hash-Tabellen (Kapitel 16)
  279.  
  280. (defmacro dohash ((keyvar valuevar HTform &optional resultform) &body body &environment env)
  281.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  282.     (let ((HTvar (gensym)))
  283.       `(BLOCK NIL
  284.          (LET ((,HTvar ,HTform))
  285.            (LET ((,keyvar NIL) (,valuevar NIL))
  286.              (DECLARE (IGNORABLE ,keyvar ,valuevar) ,@declarations)
  287.              (MAPHASH
  288.                #'(LAMBDA (,keyvar ,valuevar)
  289.                    ,@(if declarations `((DECLARE ,@declarations)) '())
  290.                    (TAGBODY ,@body-rest)
  291.                  )
  292.                ,HTvar
  293.              )
  294.              ,resultform
  295.        ) ) )
  296. ) ) )
  297.  
  298.  
  299. ;;; Funktionen für Strings (Kapitel 18)
  300.  
  301. (defun string-trim (character-bag string)
  302.   (sys::string-both-trim character-bag character-bag string)
  303. )
  304.  
  305. (defun string-left-trim (character-bag string)
  306.   (sys::string-both-trim character-bag nil string)
  307. )
  308.  
  309. (defun string-right-trim (character-bag string)
  310.   (sys::string-both-trim nil character-bag string)
  311. )
  312.  
  313.  
  314. ;;; Funktionen für Pathnames (Kapitel 23.1.5)
  315. #+LOGICAL-PATHNAMES
  316. (progn
  317.   (defun logical-pathname-translations (host)
  318.     (setq host (string-upcase host))
  319.     (or (gethash host sys::*logical-pathname-translations*) ; :test #'equal !
  320.         (error 
  321.          #L{
  322.          DEUTSCH "~S: ~S benennt keinen Logical Host."
  323.          ENGLISH "~S: ~S does not name a logical host"
  324.          FRANCAIS "~S : ~S n'est pas le nom d'un «host logique»."
  325.          }
  326.          'logical-pathname-translations host
  327.   ) )   )
  328.   (defun set-logical-pathname-translations (host translations)
  329.     (setq host (string-upcase host))
  330.     (puthash host sys::*logical-pathname-translations* ; :test #'equal !
  331.              (let ;((host-pathname (logical-pathname (string-concat host ":;"))))
  332.                   ((host-pathname (sys::make-logical-pathname :host host)))
  333.                (mapcar #'(lambda (rule)
  334.                            (cons (merge-pathnames (logical-pathname (first rule))
  335.                                                   host-pathname 'NIL
  336.                                  )
  337.                                  (rest rule)
  338.                          ) )
  339.                        translations
  340.   ) )        ) )
  341.   (defun load-logical-pathname-translations (host)
  342.     (setq host (string-upcase host))
  343.     (unless (gethash host sys::*logical-pathname-translations*) ; :test #'equal !
  344.       (set-logical-pathname-translations host
  345.         ; Woher bekommt man die Liste der Umsetzungen??
  346.         #| ; Marcus versucht es so:
  347.            (read
  348.              (open
  349.                (merge-pathnames
  350.                  (merge-pathnames host
  351.                    (string-concat (sys::getenv "CLISP_LOGICAL_PATHNAME_TRANSLATIONS"))
  352.                  )
  353.                  (make-pathname :type '#".lsp")
  354.            ) ) )
  355.         |#
  356.         (if (and (fboundp 'sys::getenv)
  357.                  (sys::getenv (string-concat "LOGICAL_HOST_" host "_FROM"))
  358.                  (sys::getenv (string-concat "LOGICAL_HOST_" host "_TO"))
  359.             )
  360.           (list (list (sys::getenv (string-concat "LOGICAL_HOST_" host "_FROM"))
  361.                       (sys::getenv (string-concat "LOGICAL_HOST_" host "_TO"))
  362.           )     )
  363.           '()
  364.   ) ) ) )
  365.   (set-logical-pathname-translations "SYS"
  366.     '#+(or DOS WIN32-DOS) (("**;*.LISP" "\\...\\*.LSP") (";**;*.LISP" "...\\*.LSP")
  367.                              ("**;*.*" "\\...\\*.*") (";**;*.*" "...\\*.*")
  368.                             )
  369.      #+(or AMIGA UNIX OS/2 WIN32-UNIX) (("**;*.LISP" "/**/*.lsp") (";**;*.LISP" "**/*.lsp")
  370.                              ("**;*.*" "/**/*.*") (";**;*.*" "**/*.*")
  371.                             )
  372.      #+ACORN-RISCOS         (("**;*.LISP" "$.**.*.lsp") (";**;*.LISP" "**.*.lsp")
  373.                              ("**;*.*" "$.**.*.*") (";**;*.*" "**.*.*")
  374.                             )
  375.   )
  376. )
  377.  
  378.  
  379. ;;; Funktionen für Zeit (Kapitel 25.4.1)
  380.  
  381. ; Hilfsfunktion für Macro TIME
  382. (defun %time (new-real1 new-real2 new-run1 new-run2 new-gc1 new-gc2
  383.               new-space1 new-space2 new-gccount
  384.               old-real1 old-real2 old-run1 old-run2 old-gc1 old-gc2
  385.               old-space1 old-space2 old-gccount)
  386.   (macrolet ((merge-2-values (val1 val2)
  387.                (if (< internal-time-units-per-second 1000000)
  388.                  `(dpb ,val1 (byte 16 16) ,val2) ; TIME_1: AMIGA, DOS, OS/2, UNIX_TIMES
  389.                  `(+ (* ,val1 internal-time-units-per-second) ,val2) ; TIME_2: UNIX sonst
  390.             )) )
  391.     (let ((Real-Time (- (merge-2-values new-real1 new-real2)
  392.                         (merge-2-values old-real1 old-real2)
  393.           )          )
  394.           (Run-Time (- (merge-2-values new-run1 new-run2)
  395.                        (merge-2-values old-run1 old-run2)
  396.           )         )
  397.           (GC-Time (- (merge-2-values new-gc1 new-gc2)
  398.                       (merge-2-values old-gc1 old-gc2)
  399.           )        )
  400.           (Space (- (dpb new-space1 (byte 24 24) new-space2)
  401.                     (dpb old-space1 (byte 24 24) old-space2)
  402.           )      )
  403.           (GC-Count (- new-gccount old-gccount))
  404.          )
  405.       (terpri)
  406.       (write-string "Real time: ")
  407.       (write (float (/ Real-Time internal-time-units-per-second)))
  408.       (write-string " sec.")
  409.       (terpri)
  410.       (write-string "Run time: ")
  411.       (write (float (/ Run-Time internal-time-units-per-second)))
  412.       (write-string " sec.")
  413.       (terpri)
  414.       (write-string "Space: ") (write Space) (write-string " Bytes")
  415.       (when (or (plusp GC-Count) (plusp GC-Time))
  416.         (terpri)
  417.         (write-string "GC: ") (write GC-Count)
  418.         (write-string ", GC time: ")
  419.         (write (float (/ GC-Time internal-time-units-per-second)))
  420.         (write-string " sec.")
  421.       )
  422. ) ) )
  423.  
  424. ; (sleep seconds) macht seconds Sekunden Pause. CLTL S. 447
  425. (defun sleep (time)
  426.   (if (and (realp time) (not (minusp time)))
  427.     (progn
  428.       ; Diese Fallunterscheidung hängt von sys::%sleep in time.d ab.
  429.       #+(or AMIGA DOS OS/2 ACORN-RISCOS) ; SLEEP_1
  430.       (if (> time '#,(floor (expt 2 31) internal-time-units-per-second))
  431.         ; Mehr als 248 bzw. 994 bzw. 497 Tage? (Denn sys::%sleep akzeptiert nur
  432.         ; Argumente < 2^32, bei #+(or DOS OS/2) sogar nur Argumente < 2^31.)
  433.         (loop ; ja -> Endlosschleife
  434.           (sys::%sleep '#,(* 86400 internal-time-units-per-second))
  435.         )
  436.         (sys::%sleep (round (* time internal-time-units-per-second)))
  437.       )
  438.       #+(or UNIX WIN32-UNIX WIN32-DOS) ; SLEEP_2
  439.       (if (> time 16700000) ; mehr als 193 Tage?
  440.         (loop (sys::%sleep 86400 0)) ; ja -> Endlosschleife
  441.         (multiple-value-bind (seconds rest) (floor time)
  442.           (sys::%sleep seconds (round (* rest 1000000)))
  443.       ) )
  444.     )
  445.     (error-of-type 'type-error
  446.       :datum time :expected-type '(REAL 0 *)
  447.       #L{
  448.       DEUTSCH "~S: Argument muß eine Zahl >=0 sein, nicht ~S"
  449.       ENGLISH "~S: argument ~S should be a nonnegative number"
  450.       FRANCAIS "~S : L'argument doit être un nombre positif ou zéro et non ~S"
  451.       }
  452.       'sleep time
  453. ) ) )
  454.  
  455.  
  456. ;; Funktionen für Zeit-Umrechnung und Zeitzonen (CLTL Kapitel 25.4.1)
  457. ;; Version 2, beinhaltet mehr Mathematik und basiert auf März-Jahren
  458.  
  459. ; Ein März-Jahr sei die Periode vom 1.3. bis 28/29.2.
  460. ; Vorteil: Umrechnung Monat/Tag <--> Jahrtag wird einfacher.
  461. ; Skizze:
  462. ;   1.1.1900            1.1.1901            1.1.1902
  463. ;                                         
  464. ;   |-------------------|-------------------|-------------------|
  465. ;   |     Jahr 1900     |     Jahr 1901     |     Jahr 1902     |
  466. ;   |--|----------------|--|----------------|--|----------------|--|
  467. ;      |  März-Jahr 1900   |  März-Jahr 1901   |  März-Jahr 1902   |
  468. ;      |-------------------|-------------------|-------------------|
  469. ;                                            
  470. ;      1.3.1900            1.3.1901            1.3.1902
  471.  
  472. ; (UTag Jahr) = Nummer des Tages 1.3.Jahr (gegenüber 1.1.1900)
  473. ; UTag(J) = 365*J + floor(J/4) - floor(J/100) + floor(J/400) - 693901
  474. ; damit  UTag(J) - UTag(J-1) = 365 + [1 falls J Schaltjahr]
  475. ; und    UTag(1899) = -306
  476. ; gelten.
  477. (defun UTag (Jahr)
  478.   (+ (* 365 Jahr) (floor Jahr 4) (- (floor Jahr 100)) (floor Jahr 400) -693901)
  479. )
  480.  
  481. ; Näherungwert:
  482. ; 365+1/4-1/100+1/400 = 365.2425 = 146097/400 .
  483. ; Durch Betrachtung einer Wertetabelle der 400-periodischen Funktion
  484. ; (J -> UTag(J)-146097/400*J) sieht man:
  485. ;   146097/400*J - 693902.4775 <= UTag(J) <= 146097/400*J - 693900.28
  486.  
  487. ; Bestimmt zu einem Tag (0 = 1.1.1900) das März-Jahr und den Tag im März-Jahr.
  488. ; (Jahr&Tag UTTag) ==> Jahr, Jahrtag
  489. ; mit (= UTTag (+ (UTag Jahr) Jahrtag))
  490. (defun Jahr&Tag (UTTag)
  491.   ; Gesucht ist das größte Jahr mit UTag(Jahr) <= UTTag.
  492.   ; Für dieses Jahr J gilt
  493.   ; 146097/400*J - 693902.4775 <= UTag(J) <= UTTag < UTag(J+1) <= 146097/400*J - 693535.0375,
  494.   ; also 146097*J - 277560991 <= 400*UTTag < 146097*J - 277414015,
  495.   ; also 146097*(J-1900) + 23309 <= 400*UTTag < 146097*(J-1900) + 170285,
  496.   ; also J + 0.159544... <= 1900 + UTTag/(146097/400) < J + 1.165561... .
  497.   (let* ((Jahr (+ 1900 (floor (- UTTag 58) 146097/400)))
  498.          (Jahresanfang (UTag Jahr)))
  499.     ; Wegen 146097*(J-1900) + 109 <= 400*(UTTag-58) < 146097*(J-1900) + 147084,
  500.     ; also J <= 1900 + (UTTag-58)/(146097/400) < J+1.006755...,
  501.     ; ist die Schätzung  Jahr := floor(1900 + (UTTag-58)/(146097/400))
  502.     ; meist richtig und jedenfalls nicht zu klein und um höchstens 1 zu groß.
  503.     (when (< UTTag Jahresanfang) ; zu groß?
  504.       (decf Jahr)
  505.       (setq Jahresanfang (UTag Jahr))
  506.     )
  507.     (values Jahr (- UTTag Jahresanfang))
  508. ) )
  509.  
  510. ; Bei vielen Betriebssystemen (nicht bei UNIX) muß die Zeitzone beim
  511. ; Installieren in timezone.lsp eingetragen werden. Hier stehen nur
  512. ; Defaultwerte.
  513.  
  514. #-(or UNIX WIN32-UNIX)
  515. ; lokale Zeitzone
  516. (defvar *default-time-zone* -1) ; Default: 1 h östlich GMT = MEZ
  517. ; NB: Zeitzone muß nicht ganzzahlig sein, sollte aber Vielfaches
  518. ; einer Sekunde sein.
  519.  
  520. #-(or UNIX WIN32-UNIX)
  521. ; Funktion, die feststellt, ob bei gegebenem März-Jahr und Tag und Stunde
  522. ; Sommerzeit gilt.
  523. (defvar *default-dst-check* ; Default: Sommerzeit nicht explizit bekannt
  524.   #'(lambda (Jahr Jahrtag Stunde) (declare (ignore Jahr Jahrtag Stunde)) nil)
  525. )
  526.  
  527. ; andere Abbildung  Jahrtag -> Monat  für decode-universal-time:
  528. ; Seien Monat und Jahrtag auf den 1. März bezogen
  529. ; (d.h. Jahrtag = 0 am 1. März, = 364 am 28. Februar, usw.,
  530. ;  und März=0,...,Dezember=9,Januar=10,Februar=11).
  531. ; Dann ist
  532. ;                Monat = floor(a*Jahrtag+b)
  533. ; sofern a und b so gewählt sind, daß die Ungleichungen
  534. ;   122*a+b >= 4, 275*a+b >= 9, 30*a+b < 1, 336*a+b < 11
  535. ; gelten. Dies ist ein Viereck im Bereich
  536. ; 0.032653... = 8/245 <= a <= 7/214 = 0.032710...,
  537. ; 0.009345... = 1/107 <= b <= 1/49 = 0.020408...,
  538. ; in dem z.B. der Punkt (a=5/153,b=2/153) liegt:
  539. ;                Monat = floor((5*Jahrtag+2)/153).
  540.  
  541. ; andere Abbildung  Monat -> Jahrtag
  542. ; für encode-universal-time und decode-universal-time:
  543. ; Seien Monat und Jahrtag auf den 1. März bezogen
  544. ; (d.h. Jahrtag = 0 am 1. März, = 364 am 28. Februar, usw.,
  545. ;  und März=0,...,Dezember=9,Januar=10,Februar=11).
  546. ; Die Abbildung
  547. ;      Monat   0  1  2  3  4   5   6   7   8   9   10  11
  548. ;      Jahrtag 0 31 61 92 122 153 184 214 245 275 306 337
  549. ; kann man schreiben
  550. ;                Jahrtag = floor(a*Monat+b)
  551. ; sofern a und b so gewählt sind, daß die Ungleichungen
  552. ;   a+b >= 31, 11*a+b >= 337, 4*a+b < 123, 9*a+b < 276
  553. ; gelten. Dies ist ein Viereck im Bereich
  554. ; 30.5714... = 214/7 <= a <= 245/8 = 30.625,
  555. ; 0.375      = 3/8   <= b <= 5/7   = 0.7142...,
  556. ; in dem z.B. der Punkt (a=153/5,b=2/5) liegt:
  557. ;                Jahrtag = floor((153*Monat+2)/5).
  558. ; Dies ist allerdings langsamer als ein Tabellenzugriff.
  559.  
  560. (macrolet ((Monat->Jahrtag (Monat) ; 0 <= Monat < 12, 0=März,...,11=Februar
  561.              `(svref '#(0 31 61 92 122 153 184 214 245 275 306 337) ,Monat)
  562.           ))
  563.  
  564. ; (encode-universal-time second minute hour date month year [time-zone]),
  565. ; CLTL S. 446
  566. (defun encode-universal-time
  567.               (Sekunde Minute Stunde Tag Monat Jahr &optional (Zeitzone nil)
  568.                &aux Monat3 Jahr3 Jahrtag UTTag)
  569.   (unless (and (and (integerp Jahr)
  570.                     (progn
  571.                       (when (<= 0 Jahr 99)
  572.                         (multiple-value-bind (i1 i2 i3 i4 i5 Jahrjetzt) (get-decoded-time)
  573.                           (declare (ignore i1 i2 i3 i4 i5))
  574.                           (setq Jahr
  575.                             (+ Jahr (* 100 (ceiling (- Jahrjetzt Jahr 50) 100)))
  576.                       ) ) )
  577.                       (<= 1900 Jahr)
  578.                )    )
  579.                (and (integerp Monat) (<= 1 Monat 12))
  580.                (progn
  581.                  (if (< Monat 3)
  582.                    (setq Jahr3 (1- Jahr)  Monat3 (+ Monat 9)) ; Monat3 10..11
  583.                    (setq Jahr3 Jahr       Monat3 (- Monat 3)) ; Monat3 0..9
  584.                  )
  585.                  (and (and (integerp Tag) (<= 1 Tag))
  586.                       (progn
  587.                         (setq Jahrtag (+ (1- Tag) (Monat->Jahrtag Monat3)))
  588.                         (setq UTTag (+ Jahrtag (UTag Jahr3)))
  589.                         (and (if (not (eql Monat3 11))
  590.                                (< Jahrtag (Monat->Jahrtag (1+ Monat3)))
  591.                                (< UTTag (UTag (1+ Jahr3)))
  592.                              )
  593.                              (and (integerp Stunde) (<= 0 Stunde 23))
  594.                              (and (integerp Minute) (<= 0 Minute 59))
  595.                              (and (integerp Sekunde) (<= 0 Sekunde 59))
  596.                              (and (progn
  597.                                     (unless Zeitzone
  598.                                       (setq Zeitzone
  599.                                         #-(or UNIX WIN32-UNIX) (- *default-time-zone*
  600.                                                   (if (funcall *default-dst-check* Jahr3 Jahrtag Stunde) 1 0)
  601.                                                )
  602.                                         #+(or UNIX WIN32-UNIX) (default-time-zone (+ (* 24 UTTag) Stunde))
  603.                                     ) )
  604.                                     (when (floatp Zeitzone) (setq Zeitzone (rational Zeitzone)))
  605.                                     (or (integerp Zeitzone)
  606.                                         (and (rationalp Zeitzone) (integerp (* 3600 Zeitzone)))
  607.                                   ) )
  608.                                   (<= -13 Zeitzone 12)
  609.           )    ) )    ) )    )
  610.     (error-of-type 'error
  611.       #L{
  612.       DEUTSCH "Inkorrektes Datum: ~S.~S.~S, ~Sh~Sm~Ss, Zeitzone ~S"
  613.       ENGLISH "incorrect date: ~S.~S.~S, ~Sh~Sm~Ss, time zone ~S"
  614.       FRANCAIS "Date incorrecte : ~S/~S/~S, ~Sh~Sm~Ss, heure ~S"
  615.       }
  616.       Tag Monat Jahr Stunde Minute Sekunde Zeitzone
  617.   ) )
  618.   (+ Sekunde
  619.      (* 60 (+ Minute
  620.               (* 60 (+ Stunde Zeitzone
  621.                        (* 24 UTTag)
  622.   )  )     )  )     )
  623. )
  624.  
  625. ; (decode-universal-time universal-time [time-zone]), CLTL S. 445
  626. (defun decode-universal-time (UT &optional (time-zone nil)
  627.                               &aux Sommerzeit Zeitzone)
  628.   (if time-zone
  629.     (setq Sommerzeit nil Zeitzone time-zone)
  630.     #-(or UNIX WIN32-UNIX)
  631.     (setq time-zone *default-time-zone*
  632.           Sommerzeit (let ((UT (- UT (round (* 3600 time-zone)))))
  633.                        (multiple-value-bind (UTTag Stunde) (floor (floor UT 3600) 24)
  634.                          (multiple-value-bind (Jahr Jahrtag) (Jahr&Tag UTTag)
  635.                            (funcall *default-dst-check* Jahr Jahrtag Stunde)
  636.                      ) ) )
  637.           Zeitzone (- time-zone (if Sommerzeit 1 0))
  638.     )
  639.     #+(or UNIX WIN32-UNIX)
  640.     (progn
  641.       (multiple-value-setq (Zeitzone Sommerzeit) (default-time-zone (floor UT 3600)))
  642.       (setq time-zone (+ Zeitzone (if Sommerzeit 1 0)))
  643.     )
  644.   )
  645.   ; time-zone = Zeitzone ohne Sommerzeitberücksichtigung,
  646.   ; Zeitzone = Zeitzone mit Sommerzeitberücksichtigung.
  647.   (let ((UTSekunden (- UT (round (* 3600 Zeitzone)))))
  648.     (multiple-value-bind (UTMinuten Sekunde) (floor UTSekunden 60)
  649.       (multiple-value-bind (UTStunden Minute) (floor UTMinuten 60)
  650.         (multiple-value-bind (UTTage Stunde) (floor UTStunden 24)
  651.           (multiple-value-bind (Jahr Jahrtag) (Jahr&Tag UTTage)
  652.             (let* ((Monat (floor (+ (* 5 Jahrtag) 2) 153))
  653.                    (Tag (1+ (- Jahrtag (Monat->Jahrtag Monat)))))
  654.               (if (< Monat 10) ; Monat März..Dezember?
  655.                 (setq Monat (+ Monat 3)) ; Monat 3..12
  656.                 (setq Monat (- Monat 9) Jahr (+ Jahr 1)) ; Monat 1..2
  657.               )
  658.               (values Sekunde Minute Stunde Tag Monat Jahr (mod UTTage 7)
  659.                       Sommerzeit time-zone
  660. ) ) ) ) ) ) ) )
  661.  
  662. ) ; Ende von macrolet
  663.  
  664. ; (get-decoded-time), CLTL S. 445
  665. (defun get-decoded-time ()
  666.   (decode-universal-time (get-universal-time))
  667. )
  668.  
  669.  
  670. ;;; Verschiedenes
  671.  
  672. ; (concat-pnames obj1 obj2) liefert zu zwei Objekten (Symbolen oder Strings)
  673. ;  ein Symbol, dessen Printname sich aus den beiden Objekten zusammensetzt.
  674. (defun concat-pnames (obj1 obj2)
  675.   (let ((str (string-concat (string obj1) (string obj2))))
  676.     (if (and (plusp (length str)) (eql (char str 0) #\:))
  677.       (intern (subseq str 1) *keyword-package*)
  678.       (intern str)
  679. ) ) )
  680.  
  681. ; (default-directory) ist ein Synonym für (cd).
  682. (defun default-directory () (cd))
  683.  
  684. ; FORMAT-Control-String zur Datumsausgabe,
  685. ; anwendbar auf eine Liste (sec min hour day month year ...),
  686. ; belegt 17-19 Zeichen
  687. (defun date-format ()
  688.   (formatter
  689.    #.
  690.    #L{
  691.    DEUTSCH "~1{~3@*~D.~4@*~D.~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  692.    ENGLISH "~1{~5@*~D/~4@*~D/~3@*~D ~2@*~2,'0D.~1@*~2,'0D.~0@*~2,'0D~:}"
  693.    FRANCAIS "~1{~3@*~D/~4@*~D/~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  694.    }
  695.   )
  696. )
  697.  
  698. ; zeigt ein Directory an.
  699. (defun dir (&optional (pathnames #+(or DOS WIN32-DOS) '("*.*\\" "*.*")
  700.                                  #+(or AMIGA UNIX OS/2 WIN32-UNIX) '("*/" "*")
  701.                                  #+ACORN-RISCOS '("*." "*" "*.*")
  702.            )          )
  703.   (flet ((onedir (pathname)
  704.            (let ((pathname-list (directory pathname :full t :circle t)))
  705.              (if (every #'atom pathname-list)
  706.                (format t "~{~%~A~}"
  707.                  (sort pathname-list #'string< :key #'namestring)
  708.                )
  709.                (let ((date-format (date-format)))
  710.                  (dolist (l (sort pathname-list #'string< :key #'(lambda (l) (namestring (first l)))))
  711.                    (format t "~%~A~40T~7D~52T~21<~@?~>"
  712.                              (first l) (fourth l) date-format (third l)
  713.                ) ) )
  714.         )) ) )
  715.     (if (listp pathnames) (mapc #'onedir pathnames) (onedir pathnames))
  716.   )
  717.   (values)
  718. )
  719.  
  720.