blob: cba68cd0c3890c3e0c1ed0f9e1f998f1a52b7334 (
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
114
115
116
117
118
119
120
121
122
123
124
|
;/**
; * Copyright (c) Rich Hickey. All rights reserved.
; * The use and distribution terms for this software are covered by the
; * Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
; * which can be found in the file CPL.TXT at the root of this distribution.
; * By using this software in any fashion, you are agreeing to be bound by
; * the terms of this license.
; * You must not remove this notice, or any other, from this software.
; **/
(defpackage :clojure
(:export :load-types :*namespace-separator*))
(in-package :clojure)
(defvar *namespace-separator* nil
"set to #\/ for JVM, #\. for CLI")
(defun ensure-package (name)
"find the package or create it if it doesn't exist"
(or (find-package name)
(make-package name :use '())))
(defun primitive-name (tn)
(or (cdr (assoc tn
'(("Z" . "boolean")
("B" . "byte")
("C" . "char")
("S" . "short")
("I" . "int")
("J" . "long")
("F" . "float")
("D" . "double")
("V" . "void"))
:test #'string-equal))
tn))
(defun java-array-name? (tn)
(eql (schar tn 0) #\[))
(defun load-types (type-file)
"generates symbols for types/classes and members in supplied typedump file
see typedump in the Java/C# side
uses *namespace-separator*
note that this interns symbols and pushes plist entries on them,
is destructive and not idempotent, so delete-package any packages prior to re-running"
(unless *namespace-separator*
(error "*namespace-separator* must be set"))
(labels
((type-name (td)
(second (assoc :name td)))
(arity (entry)
(second (assoc :arity (rest entry))))
(name (entry)
(second (assoc :name (rest entry))))
(simple-name (tn)
(when tn
(let ((base-name (if (find *namespace-separator* tn)
(subseq tn
(1+ (position *namespace-separator* tn :from-end t))
(position #\; tn :from-end t))
(primitive-name (subseq tn (if (java-array-name? tn)
(1+ (position #\[ tn :from-end t))
0))))))
(if (java-array-name? tn)
(with-output-to-string (s)
(write-string base-name s)
(dotimes (x (1+ (position #\[ tn :from-end t)))
(write-string "[]" s)))
base-name))))
(sig (entry)
(format nil "<~{~A~^*~}>"
(mapcar #'simple-name (rest (assoc :args (rest entry)))))))
(let ((type-descriptors (with-open-file (f type-file)
(read f))))
(dolist (td type-descriptors)
(let* ((split (position *namespace-separator* (type-name td) :from-end t))
(package-name (subseq (type-name td) 0 split))
(class-name (string-append (subseq (type-name td) (1+ split)) "."))
(package (ensure-package package-name))
(class-sym (intern class-name package)))
(export class-sym package)
(dolist (entry td)
(case (first entry)
(:field
(let ((field-sym (intern (string-append class-name
(name entry))
package)))
(export field-sym package)
(setf (get field-sym 'type-info) entry)))
(:ctor
(let* ((ar (arity entry))
(overloaded (member-if (lambda (e)
(and (not (equal e entry))
(eql (first e) :ctor)
(eql (arity e) ar)))
td))
(ctor-sym (intern (concatenate 'string
class-name
"new"
(when overloaded
(sig entry)))
package)))
(export ctor-sym package)
(push entry (get ctor-sym 'type-info))))
(:method
(let* ((ar (arity entry))
(nm (name entry))
(overloaded (member-if (lambda (e)
(and (not (equal e entry))
(eql (first e) :method)
(string= (name e) nm)
(eql (arity e) ar)))
td))
(method-sym (intern (concatenate 'string
class-name
nm
(when overloaded
(sig entry)))
package)))
(export method-sym package)
(push entry (get method-sym 'type-info)))))))))
t))
|
