cl-upp.lisp

(defpackage :cl-upp
  (:use :common-lisp :st-json)
  (:export #:read-spec #:include-c++))

(cl::in-package :cl-upp)

(defun adjust-symbol (name)
  "C convention to Common Lisp name convention"
  (let ((upcase (string-upcase name)))
    ;; T as a symbol conflicts with lisp
    (if (string= upcase "T") "-T"
        (substitute #\- #\_ upcase))))

(define-condition unsupported-c++-type (error)
  ((c++-type :initarg :type
             :initform nil
             :reader c++-type))
  (:documentation "The c++ type is not supported in ECL"))

(defun read-builtin (obj)
  (if (from-json-bool (getjso "float" obj))
      (case (getjso "bits" obj)
        (32 :float)
        (64 :double)
        (128 :long-double))
      (if (from-json-bool (getjso "signed" obj))
          (case (getjso "bits" obj)
            ;; void manifests as a 0-bit builtin
            (8 (if (from-json-bool (getjso "char" obj)) :char :byte))
            (16 :int16-t)
            (32 :int32-t)
            (64 :int64-t)
            ;; 128-bit numbers are unsupported for now.
            (128 (error 'unsupported-c++-type :type obj))
            (otherwise :void))
          (case (getjso "bits" obj)
            (8 (if (from-json-bool (getjso "char" obj)) :unsigned-char :unsigned-byte))
            (16 :uint16-t)
            (32 :uint32-t)
            (64 :uint64-t)
            (128 (error 'unsupported-c++-type :type obj))
            (otherwise :void)))))

(defun read-type (obj)
  (let ((kind (getjso "kind" obj)))
    (cond ((string= kind "Builtin") (read-builtin obj))
          ((string= kind "Enum") (read-builtin obj))
          ((string= kind "Pointer")
           (let ((pointee (getjso "pointee" obj)))
             (if (string= "Record" (getjso "kind" pointee))
                 :pointer-void
                 (let ((pointee-type (read-type pointee)))
                   (case pointee-type
                     ;; This notation only seems to work properly for char*
                     ((:char :unsigned-char)
                      `(* ,pointee-type))
                     (otherwise :pointer-void))
                   ))))
          (t :unknown-kind))))

(defun read-function (name obj)
  "Read function from a JSON object"
  (let ((cname (getjso "cname" obj)))
    `(ffi:def-function (,cname ,(intern (adjust-symbol cname)))
         ,(mapcar #'(lambda (val) (list (intern (adjust-symbol (getjso "cname" val)))
                                        (read-type (getjso "type" val))))
                  (getjso "args" obj))
       :returning ,(read-type (getjso "return" obj)))))

(defun read-class-ptr (name obj) "Read class from a JSON object"
  `(ffi:def-foreign-type ,(intern (adjust-symbol (getjso "cname" obj))) :pointer-void))

(defun read-spec (path dump header)
  (format dump ";; Read library: ~A~%" path)
  (let* ((spec (read-json-as-type (open path :direction :input) 'st-json:jso))
         (classes (getjso "class" spec))
         (functions (getjso "function" spec))
         (output '())
         (count 0))
    ;; declare pointers
    (mapjso #'(lambda (key value)
                (format dump ";; Class #~A: ~A~%" count key) (incf count)
                (push (read-class-ptr key value) output))
            classes)
    ;; declare the foreign C function
    (setq count 0)
    (mapjso #'(lambda (key value)
                (format dump ";; Function #~A: ~A~%" count key)
                (incf count)
                (handler-case
                    (let ((code (read-function key value)))
                      (format dump "~S~%" code)
                      (push code output))
                  (unsupported-c++-type (e) (format dump ";; Unsupported~%"))))
            functions)
    (push `(ffi:clines ,(format nil "#include <~A>" header)) output)
    (push 'progn output)
    output))

(defmacro include-c++ (path header)
  (let ((path (eval path))
        (header (eval header)))
    (with-open-file (dump (concatenate 'string path ".lisp")
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create)
      (format dump ";; This file is automatically generated by CL-UPP for debugging purposes. ~%")
      (read-spec path dump header))))