summaryrefslogtreecommitdiff
path: root/Lisp/constant-data.lisp
blob: 7d973b76036344c02d98c559b521afa93107066c (plain)
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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
(in-package #:mulk.objective-cl)


;;;; (@* "Allocation Parameters")
(defconstant +pessimistic-allocation-type+
  (loop with max-c-type = :char
        for c-type in '(:pointer :int :long :float :double
                        #-cffi-features:no-long-long :long-long
                        #-cffi-features:no-long-long :unsigned-long-long
                        :unsigned-char :unsigned-int :unsigned-long
                        :short :unsigned-short)
        when (> (cffi:foreign-type-size c-type)
                (cffi:foreign-type-size max-c-type))
          do (progn (setq max-c-type c-type))
        finally (return max-c-type)))

(defconstant +pessimistic-allocation-size+
  (cffi:foreign-type-size +pessimistic-allocation-type+))


;;;; (@* "The constant data")
;;; Copied from objc-api.h
;;; Probably ought to be generated by C code at initialisation time.
(defparameter *objcl-api-type-names*
  '((id       . #\@)
    (class    . #\#)
    (exc      . #\E)
    (sel      . #\:)
    (chr      . #\c)
    (uchr     . #\C)
    (sht      . #\s)
    (usht     . #\S)
    (int      . #\i)
    (uint     . #\I)
    (lng      . #\l)
    (ulng     . #\L)
    (lng-lng  . #\q)
    (ulng-lng . #\Q)
    (flt      . #\f)
    (dbl      . #\d)
    (bfld     . #\b)
    (bool     . #\B)
    (void     . #\v)
    (undef    . #\?)
    (ptr      . #\^)
    (charptr  . #\*)
    (atom     . #\%)
    (ary-b    . #\[)
    (ary-e    . #\])
    (union-b  . #\()
    (union-e  . #\))
    (struct-b . #\{)
    (struct-e . #\})
    (vector   . #\!)
    (complex  . #\j)))


(defparameter *objcl-type-map*
  '((id       . id)
    (class    . objc-class)
    (sel      . selector)
    (exc      . exception)
    (chr      . character)
    (int      . integer)
    (uint     . integer)
    (lng      . integer)
    (ulng     . integer)
    (sht      . integer)
    (usht     . integer)
    (lng-lng  . integer)
    (ulng-lng . integer)
    (flt      . single-float)
    (dbl      . double-float)
    (bool     . boolean)
    (ptr      . c-pointer)
    (charptr  . string)))


(defparameter *objcl-c-type-map*
  '((id       . :pointer)
    (class    . :pointer)
    (sel      . :pointer)
    (exc      . :pointer)
    (chr      . :char)
    (int      . :int)
    (uint     . :unsigned-int)
    (lng      . :long)
    (ulng     . :unsigned-long)
    (sht      . :short)
    (usht     . :unsigned-short)
    (lng-lng  . :long-long)
    (ulng-lng . :unsigned-long-long)
    (flt      . :float)
    (dbl      . :double)
    (bool     . :boolean)
    (ptr      . :pointer)
    (charptr  . :pointer)))


;;;; (@* "Constant accessors")
(declaim (ftype (function (*) symbol) lisp-value->type-name))
(defun lisp-value->type-name (value)
  (car (rassoc-if #'(lambda (type)
                      (typep value type))
                  *objcl-type-map*)))

(declaim (ftype (function (symbol) string) type-name->type-id))
(defun type-name->type-id (type-name)
  (string (cdr (assoc type-name *objcl-api-type-names*))))

(declaim (ftype (function (symbol) symbol) type-name->c-type))
(defun type-name->c-type (type-name)
  (cdr (assoc type-name *objcl-c-type-map*)))