--- /dev/null
+;;; This is code was taken from lisppaste2 and is a quick hack
+;;; to colorize lisp examples in the html generated by Texinfo.
+;;; It is not general-purpose utility, though it could easily be
+;;; turned into one.
+
+;;;; colorize-package.lisp
+
+(defpackage :colorize
+ (:use :common-lisp)
+ (:export :scan-string :format-scan :html-colorization
+ :find-coloring-type :autodetect-coloring-type
+ :coloring-types :scan :scan-any :advance :call-parent-formatter
+ :*coloring-css* :make-background-css :*css-background-class*
+ :colorize-file :colorize-file-to-stream :*version-token*))
+
+;;;; coloring-css.lisp
+
+(in-package :colorize)
+
+(defparameter *coloring-css*
+ ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;}
+a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+.special { color : #FF5000; background-color : inherit; }
+.keyword { color : #770000; background-color : inherit; }
+.comment { color : #007777; background-color : inherit; }
+.string { color : #777777; background-color : inherit; }
+.character { color : #0055AA; background-color : inherit; }
+.syntaxerror { color : #FF0000; background-color : inherit; }
+span.paren1:hover { color : inherit; background-color : #BAFFFF; }
+span.paren2:hover { color : inherit; background-color : #FFCACA; }
+span.paren3:hover { color : inherit; background-color : #FFFFBA; }
+span.paren4:hover { color : inherit; background-color : #CACAFF; }
+span.paren5:hover { color : inherit; background-color : #CAFFCA; }
+span.paren6:hover { color : inherit; background-color : #FFBAFF; }
+")
+
+(defvar *css-background-class* "lisp-bg")
+
+(defun for-css (thing)
+ (if (symbolp thing) (string-downcase (symbol-name thing))
+ thing))
+
+(defun make-background-css (color &key (class *css-background-class*) (extra nil))
+ (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:*
+.~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%"
+ class color
+ (mapcar #'(lambda (extra)
+ (format nil "~A : ~{~A ~}"
+ (for-css (first extra))
+ (mapcar #'for-css (cdr extra))))
+ extra)))
+
+;;;; colorize.lisp
+
+;(in-package :colorize)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *coloring-types* nil)
+ (defparameter *version-token* (gensym)))
+
+(defclass coloring-type ()
+ ((modes :initarg :modes :accessor coloring-type-modes)
+ (default-mode :initarg :default-mode :accessor coloring-type-default-mode)
+ (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
+ (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
+ (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
+ (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
+ (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
+ (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
+ :initform (constantly nil))
+ (parent-type :initarg :parent-type :accessor coloring-type-parent-type
+ :initform nil)
+ (visible :initarg :visible :accessor coloring-type-visible
+ :initform t)))
+
+(defun find-coloring-type (type)
+ (if (typep type 'coloring-type)
+ type
+ (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))
+
+(defun autodetect-coloring-type (name)
+ (car
+ (find name *coloring-types*
+ :key #'cdr
+ :test #'(lambda (name type)
+ (and (coloring-type-visible type)
+ (funcall (coloring-type-autodetect-function type) name))))))
+
+(defun coloring-types ()
+ (loop for type-pair in *coloring-types*
+ if (coloring-type-visible (cdr type-pair))
+ collect (cons (car type-pair)
+ (coloring-type-fancy-name (cdr type-pair)))))
+
+(defun (setf find-coloring-type) (new-value type)
+ (if new-value
+ (let ((found (assoc type *coloring-types*)))
+ (if found
+ (setf (cdr found) new-value)
+ (setf *coloring-types*
+ (nconc *coloring-types*
+ (list (cons type new-value))))))
+ (setf *coloring-types* (remove type *coloring-types* :key #'car))))
+
+(defvar *scan-calls* 0)
+
+(defvar *reset-position* nil)
+
+(defmacro with-gensyms ((&rest names) &body body)
+ `(let ,(mapcar #'(lambda (name)
+ (list name `(make-symbol ,(symbol-name name)))) names)
+ ,@body))
+
+(defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
+ (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
+ `(labels ((advance (,num)
+ (setf ,position-place (+ ,position-place ,num))
+ t)
+ (peek-any (,items &key ,not-preceded-by)
+ (incf *scan-calls*)
+ (let* ((,items (if (stringp ,items)
+ (coerce ,items 'list) ,items))
+ (,not-preceded-by (if (characterp ,not-preceded-by)
+ (string ,not-preceded-by) ,not-preceded-by))
+ (,position ,position-place)
+ (,string ,string-param))
+ (let ((,item (and
+ (< ,position (length ,string))
+ (find ,string ,items
+ :test #'(lambda (,string ,item)
+ #+nil
+ (format t "looking for ~S in ~S starting at ~S~%"
+ ,item ,string ,position)
+ (if (characterp ,item)
+ (char= (elt ,string ,position)
+ ,item)
+ (search ,item ,string :start2 ,position
+ :end2 (min (length ,string)
+ (+ ,position (length ,item))))))))))
+ (if (characterp ,item)
+ (setf ,item (string ,item)))
+ (if
+ (if ,item
+ (if ,not-preceded-by
+ (if (>= (- ,position (length ,not-preceded-by)) 0)
+ (not (string= (subseq ,string
+ (- ,position (length ,not-preceded-by))
+ ,position)
+ ,not-preceded-by))
+ t)
+ t)
+ nil)
+ ,item
+ (progn
+ (and *reset-position*
+ (setf ,position-place *reset-position*))
+ nil)))))
+ (scan-any (,items &key ,not-preceded-by)
+ (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
+ (and ,item (advance (length ,item)))))
+ (peek (,item &key ,not-preceded-by)
+ (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
+ (scan (,item &key ,not-preceded-by)
+ (scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
+ (macrolet ((set-mode (,new-mode &key ,until (,advancing t))
+ (list 'progn
+ (list 'setf ',mode-place ,new-mode)
+ (list 'setf ',mode-wait-place
+ (list 'lambda (list ',position)
+ (list 'let (list (list '*reset-position* ',position))
+ (list 'values ,until ,advancing)))))))
+ ,@body))))
+
+(defvar *formatter-local-variables*)
+
+(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
+ autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
+ invisible)
+ (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
+ `(let ((,parent-type (or (find-coloring-type ,parent)
+ (and ,parent
+ (error "No such coloring type: ~S" ,parent)))))
+ (setf (find-coloring-type ,name)
+ (make-instance 'coloring-type
+ :fancy-name ',fancy-name
+ :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type)))
+ :default-mode (or ',default-mode
+ (if ,parent-type (coloring-type-default-mode ,parent-type)))
+ ,@(if autodetect
+ `(:autodetect-function ,autodetect))
+ :parent-type ,parent-type
+ :visible (not ,invisible)
+ :formatter-initial-values (lambda nil
+ (list* ,@(mapcar #'(lambda (e)
+ `(cons ',(car e) ,(second e)))
+ formatter-variables)
+ (if ,parent-type
+ (funcall (coloring-type-formatter-initial-values ,parent-type))
+ nil)))
+ :formatter-after-hook (lambda nil
+ (symbol-macrolet ,(mapcar #'(lambda (e)
+ `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
+ formatter-variables)
+ (concatenate 'string
+ (funcall ,formatter-after-hook)
+ (if ,parent-type
+ (funcall (coloring-type-formatter-after-hook ,parent-type))
+ ""))))
+ :term-formatter
+ (symbol-macrolet ,(mapcar #'(lambda (e)
+ `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
+ formatter-variables)
+ (lambda (,term)
+ (labels ((call-parent-formatter (&optional (,type (car ,term))
+ (,string (cdr ,term)))
+ (if ,parent-type
+ (funcall (coloring-type-term-formatter ,parent-type)
+ (cons ,type ,string))))
+ (call-formatter (&optional (,type (car ,term))
+ (,string (cdr ,term)))
+ (funcall
+ (case (first ,type)
+ ,@formatters
+ (t (lambda (,type text)
+ (call-parent-formatter ,type text))))
+ ,type ,string)))
+ (call-formatter))))
+ :transition-functions
+ (list
+ ,@(loop for transition in transitions
+ collect (destructuring-bind (mode &rest table) transition
+ `(cons ',mode
+ (lambda (,current-mode ,string ,position)
+ (let ((,mode-wait (constantly nil))
+ (,position-foobage ,position))
+ (with-scanning-functions ,string ,position-foobage
+ ,current-mode ,mode-wait
+ (let ((*reset-position* ,position))
+ (cond ,@table))
+ (values ,position-foobage ,current-mode
+ (lambda (,new-position)
+ (setf ,position-foobage ,new-position)
+ (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
+ (values ,position-foobage ,advance)))))
+ )))))))))))
+
+(defun full-transition-table (coloring-type-object)
+ (let ((parent (coloring-type-parent-type coloring-type-object)))
+ (if parent
+ (append (coloring-type-transition-functions coloring-type-object)
+ (full-transition-table parent))
+ (coloring-type-transition-functions coloring-type-object))))
+
+(defun scan-string (coloring-type string)
+ (let* ((coloring-type-object (or (find-coloring-type coloring-type)
+ (error "No such coloring type: ~S" coloring-type)))
+ (transitions (full-transition-table coloring-type-object))
+ (result nil)
+ (low-bound 0)
+ (current-mode (coloring-type-default-mode coloring-type-object))
+ (mode-stack nil)
+ (current-wait (constantly nil))
+ (wait-stack nil)
+ (current-position 0)
+ (*scan-calls* 0))
+ (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
+ (let ((to (if extend new-position current-position)))
+ (if (> to low-bound)
+ (setf result (nconc result
+ (list (cons (cons current-mode mode-stack)
+ (subseq string low-bound
+ to))))))
+ (setf low-bound to)
+ (when pop
+ (pop mode-stack)
+ (pop wait-stack))
+ (when push
+ (push current-mode mode-stack)
+ (push current-wait wait-stack))
+ (setf current-mode new-mode
+ current-position new-position
+ current-wait new-wait))))
+ (loop
+ (if (> current-position (length string))
+ (return-from scan-string
+ (progn
+ (format *trace-output* "Scan was called ~S times.~%"
+ *scan-calls*)
+ (finish-current (length string) nil (constantly nil))
+ result))
+ (or
+ (loop for transition in
+ (mapcar #'cdr
+ (remove current-mode transitions
+ :key #'car
+ :test-not #'(lambda (a b)
+ (or (eql a b)
+ (if (listp b)
+ (member a b))))))
+ if
+ (and transition
+ (multiple-value-bind
+ (new-position new-mode new-wait)
+ (funcall transition current-mode string current-position)
+ (when (> new-position current-position)
+ (finish-current new-position new-mode new-wait :extend nil :push t)
+ t)))
+ return t)
+ (multiple-value-bind
+ (pos advance)
+ (funcall current-wait current-position)
+ #+nil
+ (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
+ (and pos
+ (when (> pos current-position)
+ (finish-current (if advance
+ pos
+ current-position)
+ (car mode-stack)
+ (car wait-stack)
+ :extend advance
+ :pop t)
+ t)))
+ (progn
+ (incf current-position)))
+ )))))
+
+(defun format-scan (coloring-type scan)
+ (let* ((coloring-type-object (or (find-coloring-type coloring-type)
+ (error "No such coloring type: ~S" coloring-type)))
+ (color-formatter (coloring-type-term-formatter coloring-type-object))
+ (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
+ (format nil "~{~A~}~A"
+ (mapcar color-formatter scan)
+ (funcall (coloring-type-formatter-after-hook coloring-type-object)))))
+
+(defun encode-for-pre (string)
+ (declare (simple-string string))
+ (let ((output (make-array (truncate (length string) 2/3)
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))
+ (with-output-to-string (out output)
+ (loop for char across string
+ do (case char
+ ((#\&) (write-string "&" out))
+ ((#\<) (write-string "<" out))
+ ((#\>) (write-string ">" out))
+ (t (write-char char out)))))
+ (coerce output 'simple-string)))
+
+(defun string-substitute (string substring replacement-string)
+ "String substitute by Larry Hunter. Obtained from Google"
+ (let ((substring-length (length substring))
+ (last-end 0)
+ (new-string ""))
+ (do ((next-start
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
+ (setq new-string
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
+ (setq last-end (+ next-start substring-length)))))
+
+(defun decode-from-tt (string)
+ (string-substitute (string-substitute (string-substitute string "&" "&")
+ "<" "<")
+ ">" ">"))
+
+(defun html-colorization (coloring-type string)
+ (format-scan coloring-type
+ (mapcar #'(lambda (p)
+ (cons (car p)
+ (let ((tt (encode-for-pre (cdr p))))
+ (if (and (> (length tt) 0)
+ (char= (elt tt (1- (length tt))) #\>))
+ (format nil "~A~%" tt) tt))))
+ (scan-string coloring-type string))))
+
+(defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
+ (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
+ (merge-pathnames input-file-name)
+ (make-pathname :type "lisp"
+ :defaults (merge-pathnames input-file-name))))
+ (*css-background-class* css-background))
+ (with-open-file (s input-file :direction :input)
+ (let ((lines nil)
+ (string nil))
+ (block done
+ (loop (let ((line (read-line s nil nil)))
+ (if line
+ (push line lines)
+ (return-from done)))))
+ (setf string (format nil "~{~A~%~}"
+ (nreverse lines)))
+ (if wrap
+ (format s2
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
+<html><head><style type=\"text/css\">~A~%~A</style><body>
+<table width=\"100%\"><tr><td class=\"~A\">
+<tt>~A</tt>
+</tr></td></table></body></html>"
+ *coloring-css*
+ (make-background-css "white")
+ *css-background-class*
+ (html-colorization coloring-type string))
+ (write-string (html-colorization coloring-type string) s2))))))
+
+(defun colorize-file (coloring-type input-file-name &optional output-file-name)
+ (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
+ (merge-pathnames input-file-name)
+ (make-pathname :type "lisp"
+ :defaults (merge-pathnames input-file-name))))
+ (output-file (or output-file-name
+ (make-pathname :type "html"
+ :defaults input-file))))
+ (with-open-file (s2 output-file :direction :output :if-exists :supersede)
+ (colorize-file-to-stream coloring-type input-file-name s2))))
+
+;; coloring-types.lisp
+
+;(in-package :colorize)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *version-token* (gensym)))
+
+(defparameter *symbol-characters*
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")
+
+(defparameter *non-constituent*
+ '(#\space #\tab #\newline #\linefeed #\page #\return
+ #\" #\' #\( #\) #\, #\; #\` #\[ #\]))
+
+(defparameter *special-forms*
+ '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
+ "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
+ "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
+ "return-from" "setq" "multiple-value-call"))
+
+(defparameter *common-macros*
+ '("loop" "cond" "lambda"))
+
+(defparameter *open-parens* '(#\())
+(defparameter *close-parens* '(#\)))
+
+(define-coloring-type :lisp "Basic Lisp"
+ :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
+ :multiline :character
+ :single-escaped :in-list :syntax-error)
+ :default-mode :first-char-on-line
+ :transitions
+ (((:in-list)
+ ((or
+ (scan-any *symbol-characters*)
+ (and (scan #\.) (scan-any *symbol-characters*))
+ (and (scan #\\) (advance 1)))
+ (set-mode :symbol
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((or (scan #\:) (scan "#:"))
+ (set-mode :keyword
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan "#\\")
+ (let ((count 0))
+ (set-mode :character
+ :until (progn
+ (incf count)
+ (if (> count 1)
+ (scan-any *non-constituent*)))
+ :advancing nil)))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ ((:normal :first-char-on-line)
+ ((scan #\()
+ (set-mode :in-list
+ :until (scan #\)))))
+ (:first-char-on-line
+ ((scan #\;)
+ (set-mode :comment
+ :until (scan #\newline)))
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#")))
+ ((advance 1)
+ (set-mode :normal
+ :until (scan #\newline))))
+ (:multiline
+ ((scan "#|")
+ (set-mode :multiline
+ :until (scan "|#"))))
+ ((:symbol :keyword :escaped-symbol :string)
+ ((scan #\\)
+ (let ((count 0))
+ (set-mode :single-escaped
+ :until (progn
+ (incf count)
+ (if (< count 2)
+ (advance 1))))))))
+ :formatter-variables ((paren-counter 0))
+ :formatter-after-hook (lambda nil
+ (format nil "~{~A~}"
+ (loop for i from paren-counter downto 1
+ collect "</span></span>")))
+ :formatters
+ (((:normal :first-char-on-line)
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ ((:in-list)
+ (lambda (type s)
+ (declare (ignore type))
+ (labels ((color-parens (s)
+ (let ((paren-pos (find-if-not #'null
+ (mapcar #'(lambda (c)
+ (position c s))
+ (append *open-parens*
+ *close-parens*)))))
+ (if paren-pos
+ (let ((before-paren (subseq s 0 paren-pos))
+ (after-paren (subseq s (1+ paren-pos)))
+ (paren (elt s paren-pos))
+ (open nil)
+ (count 0))
+ (when (member paren *open-parens* :test #'char=)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter)
+ (setf open t))
+ (when (member paren *close-parens* :test #'char=)
+ (decf paren-counter))
+ (if open
+ (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
+ before-paren
+ (1+ count)
+ paren *css-background-class*
+ (color-parens after-paren))
+ (format nil "~A</span>~C</span>~A"
+ before-paren
+ paren (color-parens after-paren))))
+ s))))
+ (color-parens s))))
+ ((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let* ((colon (position #\: s :from-end t))
+ (new-s (or (and colon (subseq s (1+ colon))) s)))
+ (cond
+ ((or
+ (member new-s *common-macros* :test #'string-equal)
+ (member new-s *special-forms* :test #'string-equal)
+ (some #'(lambda (e)
+ (and (> (length new-s) (length e))
+ (string-equal e (subseq new-s 0 (length e)))))
+ '("WITH-" "DEF")))
+ (format nil "<i><span class=\"symbol\">~A</span></i>" s))
+ ((and (> (length new-s) 2)
+ (char= (elt new-s 0) #\*)
+ (char= (elt new-s (1- (length new-s))) #\*))
+ (format nil "<span class=\"special\">~A</span>" s))
+ (t s)))))
+ (:keyword (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"keyword\">~A</span>"
+ s)))
+ ((:comment :multiline)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ ((:character)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ ((:string)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ ((:single-escaped)
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ ((:syntax-error)
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"syntaxerror\">~A</span>"
+ s)))))
+
+(define-coloring-type :scheme "Scheme"
+ :autodetect (lambda (text)
+ (or
+ (search "scheme" text :test #'char-equal)
+ (search "chicken" text :test #'char-equal)))
+ :parent :lisp
+ :transitions
+ (((:normal :in-list)
+ ((scan "...")
+ (set-mode :symbol
+ :until (scan-any *non-constituent*)
+ :advancing nil))
+ ((scan #\[)
+ (set-mode :in-list
+ :until (scan #\])))))
+ :formatters
+ (((:in-list)
+ (lambda (type s)
+ (declare (ignore type s))
+ (let ((*open-parens* (cons #\[ *open-parens*))
+ (*close-parens* (cons #\] *close-parens*)))
+ (call-parent-formatter))))
+ ((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((result (if (find-package :r5rs-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :elisp "Emacs Lisp"
+ :autodetect (lambda (name)
+ (member name '("emacs")
+ :test #'(lambda (name ext)
+ (search ext name :test #'char-equal))))
+ :parent :lisp
+ :formatters
+ (((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((result (if (find-package :elisp-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :common-lisp "Common Lisp"
+ :autodetect (lambda (text)
+ (search "lisp" text :test #'char-equal))
+ :parent :lisp
+ :transitions
+ (((:normal :in-list)
+ ((scan #\|)
+ (set-mode :escaped-symbol
+ :until (scan #\|)))))
+ :formatters
+ (((:symbol :escaped-symbol)
+ (lambda (type s)
+ (declare (ignore type))
+ (let* ((colon (position #\: s :from-end t :test #'char=))
+ (to-lookup (if colon (subseq s (1+ colon)) s))
+ (result (if (find-package :clhs-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
+ to-lookup))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result (call-parent-formatter))
+ (call-parent-formatter)))))))
+
+(define-coloring-type :common-lisp-file "Common Lisp File"
+ :parent :common-lisp
+ :default-mode :in-list
+ :invisible t)
+
+(defvar *c-open-parens* "([{")
+(defvar *c-close-parens* ")]}")
+
+(defvar *c-reserved-words*
+ '("auto" "break" "case" "char" "const"
+ "continue" "default" "do" "double" "else"
+ "enum" "extern" "float" "for" "goto"
+ "if" "int" "long" "register" "return"
+ "short" "signed" "sizeof" "static" "struct"
+ "switch" "typedef" "union" "unsigned" "void"
+ "volatile" "while" "__restrict" "_Bool"))
+
+(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
+(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
+
+(define-coloring-type :basic-c "Basic C"
+ :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
+ :default-mode :normal
+ :invisible t
+ :transitions
+ ((:normal
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (scan-any *c-terminators*)
+ :advancing nil))
+ ((scan "/*")
+ (set-mode :comment
+ :until (scan "*/")))
+ ((or
+ (scan-any *c-open-parens*)
+ (scan-any *c-close-parens*))
+ (set-mode :paren-ish
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\")
+ (set-mode :string
+ :until (scan #\")))
+ ((or (scan "'\\")
+ (scan #\'))
+ (set-mode :character
+ :until (advance 2))))
+ (:string
+ ((scan #\\)
+ (set-mode :single-escape
+ :until (advance 1)))))
+ :formatter-variables
+ ((paren-counter 0))
+ :formatter-after-hook (lambda nil
+ (format nil "~{~A~}"
+ (loop for i from paren-counter downto 1
+ collect "</span></span>")))
+ :formatters
+ ((:normal
+ (lambda (type s)
+ (declare (ignore type))
+ s))
+ (:comment
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"comment\">~A</span>"
+ s)))
+ (:string
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"string\">~A</span>"
+ s)))
+ (:character
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"character\">~A</span>"
+ s)))
+ (:single-escape
+ (lambda (type s)
+ (call-formatter (cdr type) s)))
+ (:paren-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (let ((open nil)
+ (count 0))
+ (if (eql (length s) 1)
+ (progn
+ (when (member (elt s 0) (coerce *c-open-parens* 'list))
+ (setf open t)
+ (setf count (mod paren-counter 6))
+ (incf paren-counter))
+ (when (member (elt s 0) (coerce *c-close-parens* 'list))
+ (setf open nil)
+ (decf paren-counter)
+ (setf count (mod paren-counter 6)))
+ (if open
+ (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
+ (1+ count) s *css-background-class*)
+ (format nil "</span>~A</span>"
+ s)))
+ s))))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ s)))
+ ))
+
+(define-coloring-type :c "C"
+ :parent :basic-c
+ :transitions
+ ((:normal
+ ((scan #\#)
+ (set-mode :preprocessor
+ :until (scan-any '(#\return #\newline))))))
+ :formatters
+ ((:preprocessor
+ (lambda (type s)
+ (declare (ignore type))
+ (format nil "<span class=\"special\">~A</span>" s)))))
+
+(defvar *c++-reserved-words*
+ '("asm" "auto" "bool" "break" "case"
+ "catch" "char" "class" "const" "const_cast"
+ "continue" "default" "delete" "do" "double"
+ "dynamic_cast" "else" "enum" "explicit" "export"
+ "extern" "false" "float" "for" "friend"
+ "goto" "if" "inline" "int" "long"
+ "mutable" "namespace" "new" "operator" "private"
+ "protected" "public" "register" "reinterpret_cast" "return"
+ "short" "signed" "sizeof" "static" "static_cast"
+ "struct" "switch" "template" "this" "throw"
+ "true" "try" "typedef" "typeid" "typename"
+ "union" "unsigned" "using" "virtual" "void"
+ "volatile" "wchar_t" "while"))
+
+(define-coloring-type :c++ "C++"
+ :parent :c
+ :transitions
+ ((:normal
+ ((scan "//")
+ (set-mode :comment
+ :until (scan-any '(#\return #\newline))))))
+ :formatters
+ ((:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *c++-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(defvar *java-reserved-words*
+ '("abstract" "boolean" "break" "byte" "case"
+ "catch" "char" "class" "const" "continue"
+ "default" "do" "double" "else" "extends"
+ "final" "finally" "float" "for" "goto"
+ "if" "implements" "import" "instanceof" "int"
+ "interface" "long" "native" "new" "package"
+ "private" "protected" "public" "return" "short"
+ "static" "strictfp" "super" "switch" "synchronized"
+ "this" "throw" "throws" "transient" "try"
+ "void" "volatile" "while"))
+
+(define-coloring-type :java "Java"
+ :parent :c++
+ :formatters
+ ((:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (if (member s *java-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>"
+ s)
+ s)))))
+
+(let ((terminate-next nil))
+ (define-coloring-type :objective-c "Objective C"
+ :autodetect (lambda (text) (search "mac" text :test #'char=))
+ :modes (:begin-message-send :end-message-send)
+ :transitions
+ ((:normal
+ ((scan #\[)
+ (set-mode :begin-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan #\])
+ (set-mode :end-message-send
+ :until (advance 1)
+ :advancing nil))
+ ((scan-any *c-begin-word*)
+ (set-mode :word-ish
+ :until (or
+ (and (peek-any '(#\:))
+ (setf terminate-next t))
+ (and terminate-next (progn
+ (setf terminate-next nil)
+ (advance 1)))
+ (scan-any *c-terminators*))
+ :advancing nil)))
+ (:word-ish
+ #+nil
+ ((scan #\:)
+ (format t "hi~%")
+ (set-mode :word-ish :until (advance 1) :advancing nil)
+ (setf terminate-next t))))
+ :parent :c++
+ :formatter-variables ((is-keyword nil) (in-message-send nil))
+ :formatters
+ ((:begin-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send t)
+ (call-formatter (cons :paren-ish type) s)))
+ (:end-message-send
+ (lambda (type s)
+ (setf is-keyword nil)
+ (setf in-message-send nil)
+ (call-formatter (cons :paren-ish type) s)))
+ (:word-ish
+ (lambda (type s)
+ (declare (ignore type))
+ (prog1
+ (let ((result (if (find-package :cocoa-lookup)
+ (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
+ s))))
+ (if result
+ (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
+ result s)
+ (if (member s *c-reserved-words* :test #'string=)
+ (format nil "<span class=\"symbol\">~A</span>" s)
+ (if in-message-send
+ (if is-keyword
+ (format nil "<span class=\"keyword\">~A</span>" s)
+ s)
+ s))))
+ (setf is-keyword (not is-keyword))))))))
+
+
+;#!/usr/bin/clisp
+;#+sbcl
+;(require :asdf)
+;(asdf:oos 'asdf:load-op :colorize)
+
+(defmacro with-each-stream-line ((var stream) &body body)
+ (let ((eof (gensym))
+ (eof-value (gensym))
+ (strm (gensym)))
+ `(let ((,strm ,stream)
+ (,eof ',eof-value))
+ (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
+ ((eql ,var ,eof))
+ ,@body))))
+
+(defun system (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *verbose-out*. Returns the shell's exit code."
+ (let ((command (apply #'format nil control-string args)))
+ (format t "; $ ~A~%" command)
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *standard-output*))
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+ #+clisp ;XXX not exactly *verbose-out*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+ ))
+
+(defun strcat (&rest strings)
+ (apply #'concatenate 'string strings))
+
+(defun string-starts-with (start str)
+ (and (>= (length str) (length start))
+ (string-equal start str :end2 (length start))))
+
+(defmacro string-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defconstant +indent+ 2
+ "Indentation used in the examples.")
+
+(defun texinfo->raw-lisp (code)
+ "Answer CODE with spurious Texinfo output removed. For use in
+preprocessing output in a @lisp block before passing to colorize."
+ (decode-from-tt
+ (with-output-to-string (output)
+ (do* ((last-position 0)
+ (next-position
+ #0=(search #1="<span class=\"roman\">" code
+ :start2 last-position :test #'char-equal)
+ #0#))
+ ((eq nil next-position)
+ (write-string code output :start last-position))
+ (write-string code output :start last-position :end next-position)
+ (let ((end (search #2="</span>" code
+ :start2 (+ next-position (length #1#))
+ :test #'char-equal)))
+ (assert (integerp end) ()
+ "Missing ~A tag in HTML for @lisp block~%~
+ HTML contents of block:~%~A" #2# code)
+ (write-string code output
+ :start (+ next-position (length #1#))
+ :end end)
+ (setf last-position (+ end (length #2#))))))))
+
+(defun process-file (from to)
+ (with-open-file (output to :direction :output :if-exists :supersede)
+ (with-open-file (input from :direction :input)
+ (let ((line-processor nil)
+ (piece-of-code '()))
+ (labels
+ ((process-line-inside-pre (line)
+ (cond ((string-starts-with "</pre>" line)
+ (with-input-from-string
+ (stream (colorize:html-colorization
+ :common-lisp
+ (texinfo->raw-lisp
+ (apply #'concatenate 'string
+ (nreverse piece-of-code)))))
+ (with-each-stream-line (cline stream)
+ (format output " ~A~%" cline)))
+ (write-line line output)
+ (setq piece-of-code '()
+ line-processor #'process-regular-line))
+ (t (let ((to-append (subseq line +indent+)))
+ (push (if (string= "" to-append)
+ " "
+ to-append) piece-of-code)
+ (push (string #\Newline) piece-of-code)))))
+ (process-regular-line (line)
+ (let ((len (some (lambda (test-string)
+ (when (string-starts-with test-string line)
+ (length test-string)))
+ '("<pre class=\"lisp\">"
+ "<pre class=\"smalllisp\">"))))
+ (cond (len
+ (format t "processing ~A~%" line)
+ (setq line-processor #'process-line-inside-pre)
+ (write-string "<pre class=\"lisp\">" output)
+ (push (subseq line (+ len +indent+)) piece-of-code)
+ (push (string #\Newline) piece-of-code))
+ (t (write-line line output))))))
+ (setf line-processor #'process-regular-line)
+ (with-each-stream-line (line input)
+ (funcall line-processor line)))))))
+
+(defun process-dir (dir)
+ (dolist (html-file (directory (make-pathname :directory (pathname-directory dir)
+ :type "html"
+ :name :wild)))
+ (let* ((name (namestring html-file))
+ (temp-name (strcat name ".temp")))
+ (process-file name temp-name)
+ (system "mv ~A ~A" temp-name name))))
+
+;; (go "/tmp/doc/manual/html_node/*.html")
+
+#+clisp
+(progn
+ (assert (first ext:*args*))
+ (process-dir (first ext:*args*)))
+
+#+sbcl
+(progn
+ (assert (second sb-ext:*posix-argv*))
+ (process-dir (second sb-ext:*posix-argv*))
+ (sb-ext:quit))
Invalid type (the GType that does not exist) is identified as a 0 or @code{NIL}.
-@example
+@lisp
(g-type-numeric "GObject") @result{} 80
(g-type-numeric 80) @result{} 80
(g-type-string "GObject") @result{} "GObject"
(g-type-string 80) @result{} "GObject"
(g-type-numeric "GtkWidget") @result{} 6905648 ;;Will be different on each run
-@end example
+@end lisp
@node g-type-string
@section g-type-string
-@code{(g-type-string g-type-designator) @result{} name}
+@lisp
+(g-type-string g-type-designator) @result{} name
+@end lisp
@table @var
@item @var{g-type-designator}
@node g-type-numeric
@section g-type-numeric
-@code{(g-type-numeric g-type-designator) @result{} GType}
+@lisp
+(g-type-numeric g-type-designator) @result{} GType
+@end lisp
@table @var
@item @var{g-type-designator}.
@node g-type=
@section g-type=
-@code{(g-type= type-1 type-2) @result{} eq}
+@lisp
+(g-type= type-1 type-2) @result{} eq
+@end lisp
@table @var
@item @var{type-1}
@node g-type/=
@section g-type/=
-@code{(g-type/= type-1 type-2) @result{} eq}
+@lisp
+(g-type/= type-1 type-2) @result{} eq
+@end lisp
@table @var
@item @var{type-1}
@node g-type-children
@section g-type-children
-@code{(g-type-children type) @result{} children}
+@lisp
+(g-type-children type) @result{} children
+@end lisp
+
@table @var
@item @var{type}
A GType designator
Returns the list of descendent types.
Example:
-@example
+@lisp
(g-type-children "GtkButton")
@result{}
("GtkToggleButton" "GtkColorButton" "GtkFontButton" "GtkLinkButton" "GtkScaleButton")
-@end example
+@end lisp
@node g-type-parent
@section g-type-parent
-@code{(g-type-parent type) @result{} parent}
+@lisp
+(g-type-parent type) @result{} parent
+@end lisp
@table @var
@item @var{type}
Returns the parent of @code{type}.
Example:
-@example
+@lisp
(g-type-parent "GtkToggleButton")
@result{}
"GtkButton"
-@end example
+@end lisp
+
@node g-type-fundamental
@section g-type-fundamental
-@code{(g-type-fundamental type) @result{} fundamental-type}
+@lisp
+(g-type-fundamental type) @result{} fundamental-type
+@end lisp
@table @var
@item @var{type}
Returns the fundamental type that is the ancestor of @code{type}.
Example:
-@example
+@lisp
(g-type-fundamental "GtkButton") @result{} "GObject"
(g-type-fundamental "GtkWindowType") @result{} "GEnum"
(g-type-fundamental "GdkEvent") @result{} "GBoxed"
-@end example
+@end lisp
@node g-type-depth
@section g-type-depth
-@code{(g-type-depth type) @result{} depth}
+@lisp
+(g-type-depth type) @result{} depth
+@end lisp
@table @var
@item @var{type}
Returns the depth of the @code{type}. Depth is the number of types between the @code{type} and its fundamental types (including both @code{type} and its fundamental type). Depth of a fundamental type equals to 1.
Example:
-@example
+@lisp
(g-type-depth "GObject") @result{} 1
(g-type-depth "GInitiallyUnowned") @result{} 2
-@end example
+@end lisp
@node g-type-next-base
@section g-type-next-base
-@code{(g-type-next-base leaf-type root-type) @result{} base-type}
+@lisp
+(g-type-next-base leaf-type root-type) @result{} base-type
+@end lisp
@table @var
@item @var{leaf-type}
@end table
Returns the next type that should be traversed from @code{root-type} in order to reach @code{leaf-type}. E.g., given type hierarchy:
-@example
+@lisp
+ GObject
\
+ GInitiallyUnowned
+ GtkContainer
\
+ GtkTable
-@end example
+@end lisp
the following will be returned:
-@example
+@lisp
(g-type-next-base "GtkTable" "GObject") @result{} "GInitiallyUnowned"
(g-type-next-base "GtkTable" "GInitiallyUnowned") @result{} "GtkObject"
(g-type-next-base "GtkTable" "GtkObject") @result{} "GtkWidget"
(g-type-next-base "GtkTable" "GtkWidget") @result{} "GtkContainer"
(g-type-next-base "GtkTable" "GtkContainer") @result{} "GtkTable"
-@end example
+@end lisp
@node Object types information
@chapter Object types information
@node g-class-property-definition
@section g-class-property-definition
-@example
+@lisp
(defstruct g-class-property-definition
name
type
constructor
constructor-only
owner-type)
-@end example
+@end lisp
@table @var
@item @var{name}
This structure identifies a single property. Its field specify attributes of a property.
Structures of this type have shortened print syntax:
-@example
+@lisp
#<PROPERTY gchararray GtkButton.label (flags: readable writable constructor)>
-@end example
+@end lisp
(When @code{*print-readably*} is T, usual @code{defstruct} print syntax is used)
@node class-properties
@section class-properties
-@code{(class-properties type) @result{} properties}
+@lisp
+(class-properties type) @result{} properties
+@end lisp
@table @var
@item @var{type}
This function returns the list of properties that are available in class @code{type}.
Example:
-@example
+@lisp
(class-properties "GtkWidget")
@result{}
(#<PROPERTY gpointer GtkObject.user-data (flags: readable writable)>
#<PROPERTY gchararray GtkWidget.tooltip-markup (flags: readable writable)>
#<PROPERTY gchararray GtkWidget.tooltip-text (flags: readable writable)>
#<PROPERTY GdkWindow GtkWidget.window (flags: readable)>)
-@end example
+@end lisp
@node class-property-info
@section class-property-info
-@code{(class-property-info type property-name) @result{} property}
+@lisp
+(class-property-info type property-name) @result{} property
+@end lisp
@table @var
@item @var{type}
Returns the property information for a single property.
Example:
-@example
+@lisp
(class-property-info "GtkButton" "label")
@result{}
#<PROPERTY gchararray GtkButton.label (flags: readable writable constructor)>
-@end example
+@end lisp
@node interface-properties
@section interface-properties
-@code{(interface-properties type) @result{} properties}
+@lisp
+(interface-properties type) @result{} properties
+@end lisp
@table @var
@item @var{type}
This function returns the list of properties that are available in interface @code{type}.
Example:
-@example
+@lisp
(interface-properties "GtkFileChooser")
@result{}
(#<PROPERTY GtkWidget GtkFileChooser.extra-widget (flags: readable writable)>
#<PROPERTY GtkWidget GtkFileChooser.preview-widget (flags: readable writable)>
#<PROPERTY gboolean GtkFileChooser.local-only (flags: readable writable)>
#<PROPERTY gboolean GtkFileChooser.do-overwrite-confirmation (flags: readable writable)>)
-@end example
+@end lisp
@node signal-info
@section signal-info
-@example
+@lisp
(defstruct signal-info
id
name
return-type
param-types
detail)
-@end example
+@end lisp
@table @var
@item @var{id}
@end table
When @code{*print-readably*} is nil, the following print syntax is used:
-@example
+@lisp
#<Signal [#1] void GObject.notify::label(GParam) [RUN-FIRST, NO-RECURSE, DETAILED, ACTION, NO-HOOKS]>
#<Signal [#54] gboolean GtkWidget.proximity-in-event(GdkEvent) [RUN-LAST]>
#<Signal [#64] void GtkWidget.drag-data-received(GdkDragContext, gint, gint, GtkSelectionData, guint, guint) [RUN-LAST]>
#<Signal [#8] void GtkObject.destroy() [RUN-CLEANUP, NO-RECURSE, NO-HOOKS]>
-@end example
+@end lisp
This syntax specifies:
@itemize
@node type-signals
@section type-signals
-@code{(type-signals type &key (include-inherited t)) @result{} signals}
+@lisp
+(type-signals type &key (include-inherited t)) @result{} signals
+@end lisp
@table @var
@item @var{type}
A GType designator
Returns the list of signals that are available in type @code{type}.
Example:
-@example
+@lisp
(type-signals "GtkLabel" :include-inherited nil)
@result{}
(#<Signal [#138] void GtkLabel.move-cursor(GtkMovementStep, gint, gboolean) [RUN-LAST, ACTION]>
#<Signal [#139] void GtkLabel.copy-clipboard() [RUN-LAST, ACTION]>
#<Signal [#140] void GtkLabel.populate-popup(GtkMenu) [RUN-LAST]>)
-@end example
+@end lisp
@node parse-signal-name
@section parse-signal-name
-@code{(parse-signal-name type signal-name) @result{} signal}
+@lisp
+(parse-signal-name type signal-name) @result{} signal
+@end lisp
@table @var
@item @var{type}
Parses the signal name and returns the corresponding information. @code{signal-name} may include the detail part.
Example:
-@example
+@lisp
(parse-signal-name "GObject" "notify::label")
@result{}
#<Signal [#1] void GObject.notify::label(GParam) [RUN-FIRST, NO-RECURSE, DETAILED, ACTION, NO-HOOKS]>
-@end example
+@end lisp
@node query-signal-info
@section query-signal-info
-@code{(query-signal-info signal-id) @result{} signal}
+@lisp
+(query-signal-info signal-id) @result{} signal
+@end lisp
@table @var
@item @var{signal-id}
An integer identifying the signal
Retrieves the signal information by its id.
Example:
-@example
+@lisp
(query-signal-info 73)
@result{}
#<Signal [#73] gboolean GtkWidget.show-help(GtkWidgetHelpType) [RUN-LAST, ACTION]>
-@end example
+@end lisp
@node g-type-interfaces
@section g-type-interfaces
-@code{(g-type-interfaces type) @result{} interfaces}
+@lisp
+(g-type-interfaces type) @result{} interfaces
+@end lisp
@table @var
@item @var{type}
Returns the list of interfaces that @code{type} implements.
Example:
-@example
+@lisp
(g-type-interfaces "GtkButton")
@result{}
("AtkImplementorIface" "GtkBuildable" "GtkActivatable")
-@end example
+@end lisp
@node g-type-interface-prerequisites
@section g-type-interface-prerequisites
-@code{(g-type-interface-prerequisites type) @result{} types}
+@lisp
+(g-type-interface-prerequisites type) @result{} types
+@end lisp
@table @var
@item @var{type}
Returns the prerequisites of an interface @code{type}. Prerequisite is a type that should be an ancestor of a type implementing interface @code{type}.
Example:
-@example
+@lisp
(g-type-interface-prerequisites "GtkCellEditable")
@result{}
("GtkObject" "GtkWidget")
-@end example
+@end lisp
@node Enum types information
@chapter Enum types information
@node enum-item
@section enum-item
-@example
+@lisp
(defstruct enum-item
name value nick)
-@end example
+@end lisp
@table @var
@item @var{name}
Structure @code{enum-item} represents a single item of an enumeration type.
Example:
-@example
+@lisp
#S(ENUM-ITEM :NAME "GTK_WINDOW_TOPLEVEL" :VALUE 0 :NICK "toplevel")
-@end example
+@end lisp
@node flags-item
@section flags-item
-@example
+@lisp
(defstruct flags-item
name value nick)
-@end example
+@end lisp
@table @var
@item @var{name}
Structure @code{flags-item} represents a single item of an flags type.
Example:
-@example
+@lisp
#S(FLAGS-ITEM
:NAME "GDK_POINTER_MOTION_HINT_MASK"
:VALUE 8
:NICK "pointer-motion-hint-mask")
-@end example
+@end lisp
@node get-enum-items
@section get-enum-items
-@code{(get-enum-items type) @result{} items}
+@lisp
+(get-enum-items type) @result{} items
+@end lisp
@table @var
@item @var{type}
Returns a list of items in an enumeration
Example:
-@example
+@lisp
(get-enum-items "GtkScrollType")
@result{}
(#S(ENUM-ITEM :NAME "GTK_SCROLL_NONE" :VALUE 0 :NICK "none")
#S(ENUM-ITEM :NAME "GTK_SCROLL_PAGE_RIGHT" :VALUE 13 :NICK "page-right")
#S(ENUM-ITEM :NAME "GTK_SCROLL_START" :VALUE 14 :NICK "start")
#S(ENUM-ITEM :NAME "GTK_SCROLL_END" :VALUE 15 :NICK "end"))
-@end example
+@end lisp
@node get-flags-items
@section get-flags-items
-@code{(get-flags-items type) @result{} items}
+@lisp
+(get-flags-items type) @result{} items
+@end lisp
@table @var
@item @var{type}
Returns a list of items in an flags type
Example:
-@example
+@lisp
(get-flags-items "GtkAttachOptions")
@result{}
(#S(FLAGS-ITEM :NAME "GTK_EXPAND" :VALUE 1 :NICK "expand")
#S(FLAGS-ITEM :NAME "GTK_SHRINK" :VALUE 2 :NICK "shrink")
#S(FLAGS-ITEM :NAME "GTK_FILL" :VALUE 4 :NICK "fill"))
-@end example
+@end lisp
@node Using GValues
@chapter Using GValues
@end itemize
Example of usage:
-@example
+@lisp
(cffi:with-foreign-object (gval 'g-value)
(set-g-value gval "Hello" "gchararray" :zero-g-value t)
(format t "~S~%" (parse-g-value gval))
(g-value-unset gval))
@result{}
"Hello"
-@end example
+@end lisp
@node g-value-zero
@section g-value-zero
-@code{(g-value-zero g-value)}
+@lisp
+(g-value-zero g-value)
+@end lisp
@table @var
@item @var{g-value}
A foreign pointer to GValue structure.
@end table
Initializes the GValue to "unset" state. Equivalent of the following initializer in C:
-@example
+@lisp
GValue value = @{ 0 @};
-@end example
+@end lisp
Must be called before other functions that work with GValue (except @code{set-g-value} with keyword argument @code{:zero-g-value} set to true).
@node g-value-init
@section g-value-init
-@code{(g-value-init value type)}
+@lisp
+(g-value-init value type)
+@end lisp
@table @var
@item @var{value}
A foreign pointer to GValue structure
@node g-value-unset
@section g-value-unset
-@code{(g-value-unset value)}
+@lisp
+(g-value-unset value)
+@end lisp
@table @var
@item @var{value}
A foreign pointer to GValue structure.
@node parse-g-value
@section parse-g-value
-@code{(parse-g-value value) @result{} object}
+@lisp
+(parse-g-value value) @result{} object
+@end lisp
@table @var
@item @var{value}
A foreign pointer to GValue structure
@node set-g-value
@section set-g-value
-@code{(set-g-value gvalue object type &key zero-g-value unset-g-value (g-value-init t))}
+@lisp
+(set-g-value gvalue object type &key zero-g-value unset-g-value (g-value-init t))
+@end lisp
@table @var
@item @var{gvalue}
Registers the @code{type} to be used for passing value of GEnum type @code{name} between GObject and Lisp.
Example:
-@example
+@lisp
(defcenum text-direction
:none :ltr :rtl)
(register-enum-type "GtkTextDirection" 'text-direction)
-@end example
+@end lisp
@subsection
@code{(register-flags-type name type)}
Registers the @code{type} to be used for passing value of GFlags type @code{name} between GObject and Lisp.
Example:
-@example
+@lisp
(defcenum state-type
:normal :active :prelight :selected :insensitive)
(register-enum-type "GtkStateType" 'state-type)
-@end example
+@end lisp
@node Stable pointers
@chapter Stable pointers
@node allocate-stable-pointer
@section allocate-stable-pointer
-@code{(allocate-stable-pointer thing) @result{} stable-pointer}
+@lisp
+(allocate-stable-pointer thing) @result{} stable-pointer
+@end lisp
@table @var
@item @var{thing}
(Note: @var{stable-pointer} should not be dereferenced with @code{cffi:mem-ref}. It should only be dereferenced with @code{stable-pointer-value})
Example:
-@example
+@lisp
(allocate-stable-pointer (lambda (x) (+ x 10)))
@result{}
#.(SB-SYS:INT-SAP #X00000002)
(free-stable-pointer **)
@result{}
NIL
-@end example
+@end lisp
@node free-stable-pointer
@section free-stable-pointer
-@code{(free-stable-pointer stable-pointer)}
+@lisp
+(free-stable-pointer stable-pointer)
+@end lisp
@table @var
@item @var{stable-pointer}
Frees the stable pointer, enabling the garbage collector to reclaim the object.
Example:
-@example
+@lisp
(allocate-stable-pointer (lambda (x) (+ x 10)))
@result{}
#.(SB-SYS:INT-SAP #X00000002)
(free-stable-pointer **)
@result{}
NIL
-@end example
+@end lisp
@node stable-pointer-value
@section stable-pointer-value
-@example
+@lisp
(stable-pointer-value stable-pointer) @result{} thing
(setf (stable-pointer-value stable-pointer) thing)
-@end example
+@end lisp
@table @var
@item @var{stable-pointer}
@node with-stable-pointer
@section with-stable-pointer
-@code{(with-stable-pointer (ptr expr) &body body)}
+@lisp
+(with-stable-pointer (ptr expr) &body body)
+@end lisp
@table @var
@item @var{ptr}
Executes the body with the @code{ptr} variable being bound to a stable pointer whose value is determined by @code{expr}.
Example:
-@example
+@lisp
(with-stable-pointer (ptr (lambda (x) (+ x 10)))
(print (stable-pointer-value ptr)))
;;Prints:
#<FUNCTION (LAMBDA (X)) @{1004807E79@}>
-@end example
+@end lisp
@node Closures
@chapter Closures
Allocates the closure. The closure is destroyed automatically by GObject.
Example:
-@example
+@lisp
(create-g-closure (lambda (x) (+ x 10)))
@result{}
#.(SB-SYS:INT-SAP #X006D7B20)
-@end example
+@end lisp
Example of usage from GObject binding code:
-@example
+@lisp
(defun connect-signal (object signal handler &key after)
(g-signal-connect-closure (ensure-object-pointer object)
signal
(create-g-closure handler)
after))
-@end example
+@end lisp
(TODO: GObject defines finer closure API: g_closure_ref, g_closure_unref, g_closure_invoke. It should be bound.)
@node g-object-call-constructor
@section g-object-call-constructor
-@code{(g-object-call-constructor object-type args-names args-values &optional args-types) @result{} object-ptr}
+@lisp
+(g-object-call-constructor object-type args-names args-values &optional args-types) @result{} object-ptr
+@end lisp
@table @var
@item @var{object-type}
Creates the object of type @code{object-type} by calling its constructors with arguments specified by @code{args-names}, @code{args-values}, @code{args-types}.
Example:
-@example
+@lisp
(g-object-call-constructor "GtkButton" '("label" "use-underline") '("Hello" t) '("gchararray" "gboolean"))
@result{}
#.(SB-SYS:INT-SAP #X006D8900)
(g-object-call-get-property ** "use-underline")
@result{}
T
-@end example
+@end lisp
@node g-type-from-object
@section g-type-from-object
-@code{(g-type-from-object object-ptr) @result{} type}
+@lisp
+(g-type-from-object object-ptr) @result{} type
+@end lisp
@table @var
@item @var{object-ptr}
Returns the type of an object by a pointer to its instance
Example:
-@example
+@lisp
(g-type-from-object (g-object-call-constructor "GtkButton" nil nil))
@result{}
"GtkButton"
-@end example
+@end lisp
@node g-object-call-get-property
@section g-object-call-get-property
-@code{(g-object-call-get-property object-ptr property-name &optional property-type) @result{} property-value}
+@lisp
+(g-object-call-get-property object-ptr property-name &optional property-type) @result{} property-value
+@end lisp
@table @var
@item @var{object-ptr}
Retrieves the value of a property @code{property-name} of object pointed to by @code{object-ptr}. @code{property-type} specifies the type of a property; it may be omitted.
Example:
-@example
+@lisp
(g-object-call-constructor "GtkButton" '("label" "use-underline") '("Hello" t) '("gchararray" "gboolean"))
@result{}
#.(SB-SYS:INT-SAP #X006D8900)
(g-object-call-get-property ** "use-underline")
@result{}
T
-@end example
+@end lisp
@node g-object-call-set-property
@section g-object-call-set-property
-@code{(g-object-call-set-property object-ptr property-name new-value &optional property-type)}
+@lisp
+(g-object-call-set-property object-ptr property-name new-value &optional property-type)
+@end lisp
@table @var
@item @var{object-ptr}
Sets the property value of property @code{property-name} of object @code{object-ptr} to @code{new-value}.
Example:
-@example
+@lisp
(g-object-call-constructor "GtkButton" nil nil)
@result{}
#.(SB-SYS:INT-SAP #X006D8B40)
(g-object-call-get-property ** "label")
@result{}
"Hello"
-@end example
+@end lisp
@node GObject high-level
@chapter GObject high-level
To be able to use particular GObject class with CLOS, it should be defined and registered. This is accomplished by @code{defclass}'ing it with @code{gobject-class} metaclass. After GObject class is defined, it may be used as CLOS class.
Example GObject class of definition:
-@example
+@lisp
(defclass dialog (gtk-window atk-implementor-iface buildable)
((has-separator :accessor dialog-has-separator
:initarg :has-separator
(:metaclass gobject-class)
(:g-type-name . "GtkDialog")
(:g-type-initializer . "gtk_dialog_get_type"))
-@end example
+@end lisp
This example defines the CLOS class @code{dialog} that corresponds to GObject class @code{GtkDialog}. Whenever object of GObject type @code{GtkDialog} are to be received from foreign functions or passed to foreign functions, it will be mapped to CLOS class @code{dialog}. Properties that have @code{:allocation} of @code{:gobject-property} are mapped to GObject properties, and reading or writing this slot reads or writes corresponding GObject class property.
Initargs of a slot are used to construct the GObject class.
Example:
-@example
+@lisp
(defclass container (widget atk-implementor-iface buildable)
((border-width :allocation :gobject-property
:g-property-type "guint"
(:metaclass gobject-class)
(:g-type-name . "GtkContainer")
(:g-type-initializer . "gtk_container_get_type"))
-@end example
+@end lisp
(note the dot in @code{(:g-type-name . "GtkContainer")} and in @code{(:g-type-initializer . "gtk_container_get_type")}. It should be present)
@node Using objects
Instances are created with @code{make-instance}. If initargs of GObject properties are supplied, they are passed to constructor. Some slots (properties) may only be set at construction time (e.g., @code{type} property of @code{GtkWindow}). Properties may be accessed (read or assigned) with defined @code{:accessor}, @code{:reader} or @code{:writer} functions.
Example:
-@example
+@lisp
(make-instance 'gtk:dialog :has-separator t)
@result{}
#<GTK:DIALOG @{10036C5A71@}>
(gtk:dialog-has-separator *d*)
@result{}
NIL
-@end example
+@end lisp
@node Signals
@section Signals
Connects the @code{handler} to signal @code{signal} on object @code{object}. Signature of @code{handler} should comply with signature of a signal. @code{handler} will be called with arguments of type specified by signal with the object (on which the signal was emitted) prepended to them and it should return the value of the signal's return type.
Example:
-@example
+@lisp
(defvar *d* (make-instance 'gtk:dialog))
@result{}
*D*
;; Prints:
#<GTK:DIALOG @{1002D866F1@}>
14
-@end example
+@end lisp
Function @code{emit-signal} is used to emit signals on objects.
Emits the signal and calls all handlers of the signal. If signal returns a value, it is returned from @code{emit-signal}.
Example:
-@example
+@lisp
(defvar *d* (make-instance 'gtk:dialog))
@result{}
*D*
;; Prints:
#<GTK:DIALOG @{1002D866F1@}>
14
-@end example
+@end lisp
@node GObject foreign class
@section GObject foreign class
When the @code{g-object} foreign type is specified as a type of function's argument, the value is converted to pointer to GObject. If @code{type} is specified then it is checked that the object is of this type.
This defines the function that may be called with instances of types @code{container} and @code{widget}:
-@example
+@lisp
(defcfun (container-add "gtk_container_add") :void
(container (g-object container))
(widget (g-object widget)))
(let ((window (make-instance 'gtk-window))
(widget (make-instance 'button)))
(container-add window widget))
-@end example
+@end lisp
(@code{gtk-window} is a subclass of @code{container}; @code{button} is a subclass of @code{widget})
This defines the function that returns an instance of GObject class:
-@example
+@lisp
(defcfun (bin-child "gtk_bin_get_child") (g-object widget)
(bin (g-object bin)))
(bin-child window))
@result{}
#<GTK:BUTTON @{1002DE74B1@}>
-@end example
+@end lisp
@node Creating GObjects classes and implementing GInterfaces
@chapter Creating GObjects classes and implementing GInterfaces
@node define-vtable
@section define-vtable
-@example
+@lisp
(define-vtable (type-name cstruct-name)
&body item*)
item ::= (name callback-name return-type &rest arg*)
item ::= (:skip cffi-structure-item)
arg ::= (arg-name arg-type)
-@end example
+@end lisp
@table @var
@item @var{type-name}
Macro that specifies the vtable for an interface. This macro defines generic functions (named by @code{name}) that correspond to methods of an interface. On these generic functions methods should be defined that implement the interface method. @code{item}s specify the CFFI foreign structure for vtable. Vtable contains not only function pointers, but other slots. Such slots should be specified here with @code{:skip} prepended to them. This is needed to be able to correctly calculate offsets to function pointers in vtable.
Example:
-@example
+@lisp
(define-vtable ("GtkTreeModel" c-gtk-tree-model)
(:skip parent-instance g-type-interface)
;;some signals
:void (tree-model g-object) (iter (g-boxed-ref tree-iter)))
(tree-model-unref-node-impl tree-model-unref-node-cb
:void (tree-model g-object) (iter (g-boxed-ref tree-iter))))
-@end example
+@end lisp
@node register-object-type-implementation
@section register-object-type-implementation
-@code{(register-object-type-implementation name class parent interfaces properties)}
+@lisp
+(register-object-type-implementation name class parent interfaces properties)
+@end lisp
@table @var
@item @var{name}
@item @var{properties}
A list of properties that this class provides.
Each property is defined as
-@example
+@lisp
property ::= (property-name property-type accessor property-get-fn property-set-fn)
-@end example
+@end lisp
@end table
A macro that creates a new GObject type and registers the Lisp implementation for it.
Example:
-@example
+@lisp
(register-object-type-implementation "LispArrayListStore" array-list-store "GObject" ("GtkTreeModel") nil)
-@end example
+@end lisp
@node GBoxed
@chapter GBoxed
@node define-g-boxed-class
@section define-g-boxed-class
-@example
+@lisp
(define-g-boxed-class g-name-and-c-name name (&optional superclass-and-dispatch (export t))
&body slot*)
g-name-and-c-name ::= (g-name c-name)
superclass-and-dispatch ::= (&optional superclass dispatch-slot dispatch-values)
slot ::= slot-name slot-type &key initform parser unparser
-@end example
+@end lisp
@table @var
@item @var{g-name}
@code{define-g-boxed-class} supports basic single inheritance. This is provided to support ``generic'' C structures like @code{GdkEvent} that contain a ``type'' field and a @code{union} of other substructures. The natural mapping of such structure to Lisp is not one, but several structures that are inherited one from another. This supports e.g. method dispatching on @code{GdkEvent} types (if it is ever necessary).
The only use of @code{define-g-boxed-class} that involves inheritance is the @code{GdkEvent} structure. It is defined as follows.
-@example
+@lisp
(define-g-boxed-class ("GdkEvent" event-struct) event ()
(type event-type)
(window (g-object gdk-window))
(device (g-object device))
(x-root :double)
(y-root :double))
-@end example
+@end lisp
Some simpler uses include following examples:
-@example
+@lisp
(define-g-boxed-class "GdkFont" font ()
(type font-type :initform :font)
(ascent :int :initform 0)
(min-aspect :double :initform 0.0d0)
(max-aspect :double :initform 0.0d0)
(gravity gravity :initform :north-west))
-@end example
+@end lisp
@node define-g-boxed-ref
@section define-g-boxed-ref
@code{g-boxed-ref} class is defined:
-@example
+@lisp
(defclass g-boxed-ref ()
((pointer :accessor pointer :initarg :pointer)))
-@end example
+@end lisp
This class holds the pointer to structure. GBoxed-ref types are subclasses of this class.
-@example
+@lisp
(define-g-boxed-ref g-name name
&rest property*)
property ::= (:alloc-function alloc-function)
property ::= (:slots &rest slot*)
slot ::= (slot-name &key reader writer type (accessor slot-name))
-@end example
+@end lisp
@table @var
@item @var{g-name}
The memory occupied by this class is managed automatically: after the GC collects the Lisp instance, @code{free-function} is used to free the structure (if the instance was created by lisp code).
Example:
-@example
+@lisp
(defcstruct tree-iter
(stamp :int)
(user-data :pointer)
(user-data :reader tree-iter-get-user-data :writer tree-iter-set-user-data :accessor tree-iter-user-data))
(:alloc-function tree-iter-alloc)
(:free-function tree-iter-free))
-@end example
+@end lisp
Another example:
-@example
+@lisp
(define-foreign-type unichar ()
()
(:actual-type :uint32)
(defun gtk-text-iter-alloc ()
(with-foreign-object (iter '%text-iter)
(gtk-text-iter-copy iter)))
-@end example
+@end lisp
@node Generating type definitions by introspection
@chapter Generating type definitions by introspection
@node define-g-object-class
@section define-g-object-class
-@example
+@lisp
(define-g-object-class g-type-name name
(&key (superclass 'g-object) (export t) interfaces type-initializer)
(&rest property*))
property ::= (name accessor gname type readable writable)
property ::= (:cffi name acessor type reader writer)
-@end example
+@end lisp
Parameters of @code{define-g-object-class}
@table @var
Macro that expands to @code{defclass} for specified class. Additionally, if @code{export} is true, it exports accessor names and name of a class.
Example:
-@example
+@lisp
(define-g-object-class "GtkContainer" container
(:superclass widget :export t :interfaces
("AtkImplementorIface" "GtkBuildable")
(:cffi focus-child container-focus-child g-object "gtk_container_get_focus_child" "gtk_container_set_focus_child")
(:cffi focus-vadjustment container-focus-vadjustment (g-object adjustment) "gtk_container_get_focus_vadjustment" "gtk_container_set_focus_vadjustment")
(:cffi focus-hadjustment container-focus-hadjustment (g-object adjustment) "gtk_container_get_focus_hadjustment" "gtk_container_set_focus_hadjustment")))
-@end example
+@end lisp
@node define-g-interface
@section define-g-interface
-@example
+@lisp
(define-g-interface g-type-name name (&key (export t) type-initializer)
&body property*)
property ::= (name accessor gname type readable writable)
property ::= (:cffi name acessor type reader writer)
-@end example
+@end lisp
Parameters of @code{define-g-interface}
@table @var
Macro that expands to @code{defclass} for specified interface. Additionally, if @code{export} is true, it exports accessor names and name of a interface.
Example:
-@example
+@lisp
(define-g-interface "GtkFileChooser" file-chooser
(:export t :type-initializer "gtk_file_chooser_get_type")
(do-overwrite-confirmation file-chooser-do-overwrite-confirmation "do-overwrite-confirmation" "gboolean" t t)
(:cffi preview-uri file-chooser-preview-uri
(g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_preview_uri" nil))
-@end example
+@end lisp
@node define-g-enum
@section define-g-enum
-@example
+@lisp
(define-g-enum g-name name (&key (export t) type-initializer) &body value*)
value ::= :keyword
value ::= (:keyword integer)
-@end example
+@end lisp
@table @var
@item @var{g-name}
Macro that defines CFFI enumeration, registers it with GValue, and calls the type initializer.
Example:
-@example
+@lisp
(define-g-enum "GtkTextDirection" text-direction
(:export t :type-initializer "gtk_text_direction_get_type")
(:none 0) (:ltr 1) (:rtl 2))
(define-g-enum "GtkSizeGroupMode" size-group-mode
(:export t :type-initializer "gtk_size_group_mode_get_type")
:none :horizontal :vertical :both)
-@end example
+@end lisp
@node define-g-flags
@section define-g-flags
-@example
+@lisp
(define-g-flags g-name name (&key (export t) type-initializer) &body value*)
value ::= :keyword
value ::= (:keyword integer)
-@end example
+@end lisp
@table @var
@item @var{g-name}
Macro that defines CFFI bitfield, registers it with GValue, and calls the type initializer.
Example:
-@example
+@lisp
(define-g-flags "GtkAttachOptions" attach-options
(:export t :type-initializer "gtk_attach_options_get_type")
(:expand 1) (:shrink 2) (:fill 4))
(define-g-flags "GtkButtonAction" button-action
(:export t :type-initializer "gtk_button_action_get_type")
:ignored :selects :drags :expands)
-@end example
+@end lisp
@node get-g-enum-definition
@section get-g-enum-definition
-@code{(get-g-enum-definition type &optional lisp-name-package) @result{} definition}
+@lisp
+(get-g-enum-definition type &optional lisp-name-package) @result{} definition
+@end lisp
@table @var
@item @var{type}
See @ref{Generating names for CLOS classes and accessors} for information about used method for generating names.
Example:
-@example
+@lisp
(get-g-enum-definition "GtkDirectionType")
@result{}
(DEFINE-G-ENUM "GtkDirectionType" GTK-DIRECTION-TYPE
(:EXPORT T :TYPE-INITIALIZER "gtk_direction_type_get_type")
(:TAB-FORWARD 0) (:TAB-BACKWARD 1) (:UP 2) (:DOWN 3) (:LEFT 4)
(:RIGHT 5))
-@end example
+@end lisp
@node get-g-flags-definition
@section get-g-flags-definition
-@code{(get-g-flags-definition type &optional lisp-name-package) @result{} definition}
+@lisp
+(get-g-flags-definition type &optional lisp-name-package) @result{} definition
+@end lisp
@table @var
@item @var{type}
See @ref{Generating names for CLOS classes and accessors} for information about used method for generating names.
Example:
-@example
+@lisp
(get-g-flags-definition "GtkCalendarDisplayOptions")
@result{}
(DEFINE-G-FLAGS "GtkCalendarDisplayOptions" GTK-CALENDAR-DISPLAY-OPTIONS
(:SHOW-HEADING 1) (:SHOW-DAY-NAMES 2) (:NO-MONTH-CHANGE 4)
(:SHOW-WEEK-NUMBERS 8) (:WEEK-START-MONDAY 16)
(:SHOW-DETAILS 32))
-@end example
+@end lisp
@node get-g-interface-definition
@section get-g-interface-definition
-@code{get-g-interface-definition type &optional lisp-name-package) @result{} definition}
+@lisp
+get-g-interface-definition type &optional lisp-name-package) @result{} definition
+@end lisp
@table @var
@item @var{type}
See @ref{Generating names for CLOS classes and accessors} for information about used method for generating names.
Example:
-@example
+@lisp
(get-g-interface-definition "GtkActivatable")
@result{}
(DEFINE-G-INTERFACE "GtkActivatable" GTK-ACTIVATABLE
"use-action-appearance" "gboolean" T T)
(RELATED-ACTION GTK-ACTIVATABLE-RELATED-ACTION
"related-action" "GtkAction" T T))
-@end example
+@end lisp
@node get-g-class-definition
@section get-g-class-definition
-@code{get-g-class-definition type &optional lisp-name-package) @result{} definition}
+@lisp
+get-g-class-definition type &optional lisp-name-package) @result{} definition
+@end lisp
@table @var
@item @var{type}
See @ref{Generating names for CLOS classes and accessors} for information about used method for generating names.
Example:
-@example
+@lisp
(get-g-class-definition "GtkButton")
@result{}
(DEFINE-G-OBJECT-CLASS "GtkButton" GTK-BUTTON
(YALIGN GTK-BUTTON-YALIGN "yalign" "gfloat" T T)
(IMAGE-POSITION GTK-BUTTON-IMAGE-POSITION
"image-position" "GtkPositionType" T T)))
-@end example
+@end lisp
@node Specifying additional properties for CLOS classes
@section Specifying additional properties for CLOS classes
To supply the bindings generator with this information, bind @code{*additional-properties*} to such list when the generator is run.
Example:
-@example
+@lisp
(("GtkTreeViewColumn"
(:cffi gtk::tree-view
gtk::tree-view-column-tree-view
(:cffi gtk::select-function
gtk::tree-selection-select-function
nil gtk::tree-selection-get-selection-function gtk::tree-selection-set-select-function)))
-@end example
+@end lisp
@node Generating names for CLOS classes and accessors
@section Generating names for CLOS classes and accessors
@item @var{*lisp-name-exceptions*}
A plist mapping from strings (type names) to symbols (class names) that have special name processing.
Example:
-@example
+@lisp
`(("GObject" gobject:g-object)
("GtkObject" ,(intern "GTK-OBJECT" (find-package :gtk)))
("GInitiallyUnowned" gobject::g-initially-unowned)
("GtkWindow" ,(intern "GTK-WINDOW" (find-package :gtk)))
("GtkUIManager" ,(intern "UI-MANAGER" (find-package :gtk)))
("GtkUIManagerItemType" ,(intern "UI-MANAGER-ITEM-TYPE" (find-package :gtk))))
-@end example
+@end lisp
@end itemize
@node generate-types-hierarchy-to-file
@section generate-types-hierarchy-to-file
-@example
+@lisp
(generate-types-hierarchy-to-file file
root-type
&key include-referenced
objects
exclusions
additional-properties)
-@end example
+@end lisp
@table @var
@item @var{file}
Generates definitions for all types in a type hierarchy. Recursively scan types hierarchy (starting from @code{root} and @code{objects} and @code{interfaces}) (except types that were specifically excluded) and generate defintion for every mentioned type. Parameters control various aspects of definition generation.
Example of usage:
-@example
+@lisp
(generate-types-hierarchy-to-file
"gtk.generated-classes.lisp"
"GtkObject"
nil)
...)
...))
-@end example
+@end lisp
@bye
projects / cl-gtk2.git / commitdiff