-
Notifications
You must be signed in to change notification settings - Fork 0
/
cl-upp.lisp
108 lines (99 loc) · 4.14 KB
/
cl-upp.lisp
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
(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))))