forked from AuroraMiddleware/gtk
138 lines
3.2 KiB
EmacsLisp
138 lines
3.2 KiB
EmacsLisp
(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)
|