/[gtk-cffi]/gtk-cffi/gtk/common.lisp
ViewVC logotype

Contents of /gtk-cffi/gtk/common.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sat Sep 10 16:26:11 2011 UTC (2 years, 7 months ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -3 lines
Some refactoring. Now we can use (show #(1 2 3)) or (show '(1 2 3)) to lookup
through the sequence in GTK list view
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; gtk-cffi.lisp --- Common functions of gtk-cffi
4 ;;;
5 ;;; Copyright (C) 2007, Roman Klochkov <kalimehtar@mail.ru>
6 ;;;
7
8 (in-package :gtk-cffi)
9
10 (defcfun ("gtk_init" %gtk-init) :void (argc :pointer) (argv :pointer))
11
12 (defun gtk-init ()
13 ;(load-gtk)
14 #+sbcl (sb-ext::set-floating-point-modes :traps nil)
15 (with-foreign-objects ((argc :int) (argv :pointer))
16 (setf (mem-ref argc :int) 0
17 (mem-ref argv :pointer) (foreign-alloc :string
18 :initial-element "program"))
19 (%gtk-init argc argv)))
20
21 (defcfun "gtk_main" :void)
22
23 (defcfun "gtk_main_quit" :void)
24
25 (defun defmodel (body)
26 "
27 Source:
28 `(window :height 100
29 :width 100
30 :title ,(get-title)
31 :signals ,(list ...)
32 (:h-box
33 (:label :id :label1)
34 (:button :id :button1)))
35
36 Dest:
37
38 (make-instance 'window
39 :height 100
40 :width 100
41 :title (get-title)
42 :signals (list ...)
43 :kid (make-instance 'h-box
44 :kids
45 (list
46 (make-instance 'label :id :label1)
47 (make-instance 'button :id :button1))))
48 "
49 (labels
50 ((rest-translate (l)
51 "(:height 100 (:label) (:h-box)) -> (:height 100 :kids (list ....))"
52 (when l
53 (if (listp (car l))
54 (if (cdr l)
55 `(:kids (list ,@(mapcar #'translate l)))
56 `(:kid ,(translate (car l))))
57 (cons (first l)
58 (cons (second l)
59 (rest-translate (cddr l)))))))
60 (translate (l)
61 "(:widget ...) -> (make-instance 'widget ...)"
62 (if (keywordp (first l))
63 (apply #'make-instance
64 (intern (symbol-name (first l)))
65 (rest-translate (rest l)))
66 (translate (eval l)))))
67 (translate body)))
68
69
70 (defmacro gtk-model (&body body)
71 "Structure of BODY is ('widget :param1 val1 :param2 val2 ... :paramn valn ('subwidget1 ...) ('subwidget2 ...))"
72 (macrolet
73 ((pushkids (x &optional always)
74 (if always
75 `(prog1 nil (push ,x kids))
76 `(if kids (pushkids ,x t) (list ,x)))))
77 (labels
78 ((process
79 (node)
80 (let* ((kids)
81 (head (mapcan
82 (lambda (x)
83 (cond
84 ;; ... atom ... = param or value
85 ((not (consp x)) (pushkids x))
86 ;; ... ((...) ...) ... is a subwidget
87 ((consp (car x)) (pushkids (process x) t))
88 ;; (quote atom) is a widget
89 ((and
90 (eq (car x) 'quote)
91 (atom (second x))) (list 'make-instance x))
92 (t (pushkids x))))
93 node)))
94 (append head
95 (when kids
96 (if (cdr kids)
97 (list :kids (cons 'list (nreverse kids)))
98 (list :kid (car kids))))))))
99 (process body))))
100
101

  ViewVC Help
Powered by ViewVC 1.1.5