blob: 2de6a92d2b349c7067bdec1287443a5c6faaaef9 (
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
125
126
127
128
129
130
131
132
133
134
135
136
137
|
(require 'cl)
;;; file access
(defun read-file (name)
(let ((buf (generate-new-buffer "infile"))
(res nil))
(save-excursion
(set-buffer buf)
(insert-file-contents name)
(condition-case nil
(while t
(setq res (cons (read buf) res)))
(end-of-file (reverse res))))))
(defun setup-outfile ()
(setq standard-output (generate-new-buffer "outfile")))
(defun write-outfile (name)
(save-excursion
(set-buffer standard-output)
(write-region (point-min) (point-max) name)))
;;; string stunts
(defun char-upper-case-p (ch)
(eql (upcase ch) ch))
(defun char-lower-case-p (ch)
(eql (downcase ch) ch))
(defun canonicalize (str)
(if (symbolp str)
(setq str (symbol-name str)))
(let ((res nil)
(start 0)
(pos 0)
(end (length str))
(prevlower nil))
(while (< pos end)
(let ((ch (elt str pos)))
(cond ((memq ch '(?- ?_))
(setq res (cons (substring str start pos) res)
prevlower nil
pos (1+ pos)
start pos))
((and (char-upper-case-p ch)
prevlower)
(setq res (cons (substring str start pos) res)
start pos
pos (1+ pos)
prevlower nil))
(t
(setq pos (1+ pos)
prevlower (char-lower-case-p ch))))))
(reverse (mapcar 'downcase (cons (substring str start end) res)))))
(defun syllables-to-string (syls del)
(let ((res ""))
(while syls
(setq res (format "%s%s%s" res (car syls)
(if (cdr syls) del ""))
syls (cdr syls)))
res))
(defun macroname (canon)
(syllables-to-string (mapcar 'upcase canon) "_"))
(defun funcname (canon)
(syllables-to-string canon "_"))
(defun typename (canon)
(syllables-to-string (mapcar 'capitalize canon) ""))
(defun scmname (canon)
(syllables-to-string canon "-"))
(defun short-name (canon)
(if (equal (car canon) "gtk") (cdr canon) canon))
;;; Code generation
(defun printf (&rest args)
(princ (apply 'format args)))
(defun interestingp (form)
(and (listp form)
(memq (car form) '(define-enum define-flags define-boxed))))
(defun map-interesting (func defs)
(mapcar #'(lambda (form)
(if (interestingp form)
(funcall func form)))
defs))
(defun emit-idmacs (defs)
(let ((i 0))
(map-interesting
#'(lambda (form)
(let ((name (canonicalize (cadr form))))
(printf "#define GTK_TYPE_%s (gtk_type_builtins[%d])\n"
(macroname (short-name name)) i))
(setq i (1+ i)))
defs)
(printf "#define GTK_TYPE_NUM_BUILTINS %d\n" i)))
(defun emit-ids (defs)
(map-interesting
#'(lambda (form)
(printf " { %S, %s },\n"
(symbol-name (cadr form))
(case (car form)
((define-enum) "GTK_TYPE_ENUM")
((define-flags) "GTK_TYPE_FLAGS")
((define-boxed) "GTK_TYPE_BOXED"))))
defs))
(if (< (length command-line-args-left) 3)
(error "args: op def-file output-file"))
(setq op (intern (car command-line-args-left)))
(setq defs (read-file (cadr command-line-args-left)))
(setq outfile (caddr command-line-args-left))
(setq command-line-args-left nil)
(setup-outfile)
(printf "/* generated by gentypeinfo from \"gtk.defs\" */\n\n")
(case op
((idmac)
(emit-idmacs defs))
((id)
(emit-ids defs))
(else
(error "supported ops are: idmac id")))
(write-outfile outfile)
|
