clic/3rdparties/software/trivial-features-20200427-git/tests/tests.lisp

3rdparties/software/trivial-features-20200427-git/tests/tests.lisp (4001 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; tests.lisp --- trivial-features tests.
4 ;;;
5 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@common-lisp.net>
6 ;;;
7 ;;; Permission is hereby granted, free of charge, to any person
8 ;;; obtaining a copy of this software and associated documentation
9 ;;; files (the "Software"), to deal in the Software without
10 ;;; restriction, including without limitation the rights to use, copy,
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 ;;; of the Software, and to permit persons to whom the Software is
13 ;;; furnished to do so, subject to the following conditions:
14 ;;;
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
17 ;;;
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 ;;; DEALINGS IN THE SOFTWARE.
26 
27 (in-package :trivial-features-tests)
28 
29 (defun run ()
30   (let ((*package* (find-package :trivial-features-tests)))
31     (do-tests)
32     (null (regression-test:pending-tests))))
33 
34 ;;;; Support Code
35 
36 #-windows
37 (progn
38   ;; Hmm, why not just use OSICAT-POSIX:UNAME?
39   (defcfun ("uname" %uname) :int
40     (buf :pointer))
41 
42   ;; Get system identification.
43   (defun uname ()
44     (with-foreign-object (buf '(:struct utsname))
45       (when (= (%uname buf) -1)
46         (error "uname() returned -1"))
47       (macrolet ((utsname-slot (name)
48                    `(foreign-string-to-lisp
49                      (foreign-slot-pointer buf 'utsname ',name))))
50         (values (utsname-slot sysname)
51                 ;; (utsname-slot nodename)
52                 ;; (utsname-slot release)
53                 ;; (utsname-slot version)
54                 (utsname-slot machine))))))
55 
56 (defun mutually-exclusive-p (features)
57   (= 1 (loop for feature in features when (featurep feature) count 1)))
58 
59 ;;;; Tests
60 
61 (deftest endianness.1
62     (with-foreign-object (p :uint16)
63       (setf (mem-ref p :uint16) #xfeff)
64       (ecase (mem-ref p :uint8)
65         (#xfe (featurep :big-endian))
66         (#xff (featurep :little-endian))))
67   t)
68 
69 (defparameter *bsds* '(:darwin :netbsd :openbsd :freebsd))
70 (defparameter *unices* (list* :linux *bsds*))
71 
72 #+windows
73 (deftest os.1
74     (featurep (list* :or :unix *unices*))
75   nil)
76 
77 #-windows
78 (deftest os.1
79     (featurep (make-keyword (string-upcase (uname))))
80   t)
81 
82 (deftest os.2
83     (if (featurep :bsd)
84         (mutually-exclusive-p *bsds*)
85         (featurep `(:not (:or ,@*bsds*))))
86   t)
87 
88 (deftest os.3
89     (if (featurep `(:or ,@*unices*))
90         (featurep :unix)
91         t)
92   t)
93 
94 (deftest os.4
95     (if (featurep :windows)
96         (not (featurep :unix))
97         t)
98   t)
99 
100 (deftest cpu.1
101     (mutually-exclusive-p '(:ppc :ppc64 :x86 :x86-64 :alpha :mips))
102   t)
103 
104 #+windows
105 (deftest cpu.2
106     (case (get-system-info)
107       (:intel (featurep :x86))
108       (:amd64 (featurep :x86-64))
109       (:ia64 nil) ; add this feature later!
110       (t t))
111   t)
112 
113 #-windows
114 (deftest cpu.2
115     (let ((machine (nth-value 1 (uname))))
116       (cond ((member machine '("x86" "x86_64") :test #'string=)
117              (ecase (foreign-type-size :pointer)
118                (4 (featurep :x86))
119                (8 (featurep :x86-64))))
120             (t
121              (format *debug-io*
122                      "~&; NOTE: unhandled machine type, ~a, in CPU.2 test.~%"
123                      machine)
124              t)))
125   t)
126 
127 (deftest cpu.3
128     (ecase (foreign-type-size :pointer)
129       (4 (featurep :32-bit))
130       (8 (featurep :64-bit)))
131   t)
132 
133 ;; regression test: sometimes, silly logic leads to pushing nil to
134 ;; *features*.
135 (deftest nil.1 (featurep nil) nil)
136 (deftest nil.2 (featurep :nil) nil)