;;;; Objective-CL, an Objective-C bridge for Common Lisp.
;;;; Copyright (C) 2007  Matthias Andreas Benkard.
;;;;
;;;; This program is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public License
;;;; as published by the Free Software Foundation, either version 3 of
;;;; the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful, but
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this program.  If not, see
;;;; <http://www.gnu.org/licenses/>.

(in-package #:mulk.objective-cl)
#.(in-type-declaration-syntax)


;;;; (@* "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-typespec-map*
  '((id                  . id)
    (objective-c-class   . class)
    (exception           . exc)
    (selector            . sel)
    (:id                 . id)
    (:class              . class)
    (:exception          . exc)
    (:selector           . sel)
    (:char               . chr)
    (:unsigned-char      . uchr)
    (:short              . sht)
    (:unsigned-short     . usht)
    (:int                . int)
    (:unsigned-int       . uint)
    (:long               . lng)
    (:unsigned-long      . ulng)
    (:long-long          . lng-lng)
    (:unsigned-long-long . ulng-lng)
    (:float              . flt)
    (:double             . dbl)
    (bit-field           . bfld)
    (:boolean            . bool)
    (:void               . void)
    (:unknown            . undef)
    (pointer             . ptr)
    (:pointer            . ptr)
    (:string             . charptr)
    (:atom               . atom)
    (array               . (ary-b ary-e))
    (union               . (union-b union-e))
    (struct              . (struct-b struct-e))
    (vector              . vector)
    (complex             . complex)))


(defparameter *objcl-type-map*
  '((id       . id)
    (class    . objective-c-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)
    (charptr  . string)
    (ptr      . c-pointer)))


(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")
#? * -> symbol
(defun lisp-value->type-name (value)
  (car (rassoc-if #'(lambda (type)
                      (typep value type))
                  *objcl-type-map*)))

#? symbol -> string
(defun type-name->type-id (type-name)
  (string (cdr (assoc type-name *objcl-api-type-names*))))

#? symbol -> symbol
(defun type-name->c-type (type-name)
  (cdr (assoc type-name *objcl-c-type-map*)))

#? symbol -> symbol
(defun typespec-name->type-name (typespec-name)
  (cdr (assoc typespec-name *objcl-typespec-map*)))

#? symbol -> string
(defun typespec-name->type-id (typespec-name)
  (type-name->type-id (typespec-name->type-name typespec-name)))