ctype/runtime.lisp at main · s-expressionists/ctype · GitHub

1
2
3
4
5
6
7
8
9
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
(in-package #:ctype)

;;;; These are the functions that need to be specialized for CTYPEP to work,
;;;; rather than just defining the type system.
;;;; They cannot be implemented portably except through CL:TYPEP and CL:SUBTYPEP,
;;;; so any Lisp implementation using ctype to implement those functions must
;;;; provide its own specializations for these functions.

(defmethod range-kindp (client object kind)
  (declare (ignore client))
  (cl:typep object kind))
;; Some extras to be a tiny bit faster, maybe.
(macrolet ((defrange (kind)
             `(progn
                (defmethod range-kindp (client (object ,kind) (kind (eql ',kind)))
                  (declare (ignore client))
                  t)
                (defmethod range-kindp (client object (kind (eql ',kind)))
                  (declare (ignore client))
                  nil)))
           (defrange~ (kind &environment e)
             ;; define these methods, but only if the host actually has
             ;; classes for these types, which is not guaranteed.
             (if (cl:find-class kind nil e)
                 `(defrange ,kind)
                 nil)))
  (defrange integer)
  (defrange ratio)
  (defrange~ short-float)
  (defrange~ single-float)
  (defrange~ double-float)
  (defrange~ long-float))

(macrolet ((defsap (&environment e)
             ;; simple-array is a type in the standard, so it may or may not
             ;; correspond to a class.
             (if (cl:find-class 'cl:simple-array nil e)
                 `(progn
                    (defmethod simple-array-p (client (object simple-array))
                      (declare (ignore client))
                      t)
                    (defmethod simple-array-p (client object)
                      (declare (ignore client object))
                      nil))
                 `(defmethod simple-array-p (client object)
                   (declare (ignore client))
                   (cl:typep object 'cl:simple-array)))))
  (defsap))

(defmethod subclassp (client (sub class) (super class))
  (declare (ignore client))
  (values (cl:subtypep sub super)))