(in-package #:mulk.objective-cl)


;;;; (@* "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-data-map*
  '((id       . id-val)
    (class    . class-val)
    (exc      . exc-val)
    (sel      . sel-val)
    (chr      . char-val)
    (uchr     . char-val)
    (sht      . short-val)
    (usht     . short-val)
    (int      . int-val)
    (uint     . int-val)
    (lng      . long-val)
    (ulng     . long-val)
    (lng-lng  . long-long-val)
    (ulng-lng . long-long-val)
    (flt      . float-val)
    (dbl      . double-val)
    (bool     . bool-val)
    (ptr      . ptr-val)
    (charptr  . charptr-val)))


(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) symbol) type-name->lisp-type))
(defun type-name->lisp-type (type-name)
  (cdr (assoc type-name *objcl-type-map*)))

(declaim (ftype (function (symbol) symbol) type-name->slot-name))
(defun type-name->slot-name (type-name)
  (cdr (assoc type-name *objcl-data-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 (string) symbol) type-id->type-name))
(defun type-id->type-name (type-id)
  (car (rassoc (char type-id 0) *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*)))