[cells-cvs] CVS cells-gtk

ktilton ktilton at common-lisp.net
Mon Jan 28 23:59:25 UTC 2008


Update of /project/cells/cvsroot/cells-gtk
In directory clnet:/tmp/cvs-serv9292

Added Files:
	INSTALL.TXT actions.lisp addon.lisp asdf.lisp buttons.lisp 
	callback.lisp cells-gtk.asd cells-gtk.lpr 
	cells3-porting-notes.lisp clisp.bat compat.lisp 
	conditions.lisp dialogs.lisp display.lisp drawing.lisp 
	entry.lisp gtk-app-save.lisp gtk-app-win32.lisp gtk-app.lisp 
	layout.lisp lisp.bat load.lisp menus.lisp packages.lisp 
	pod-notes.txt textview.lisp tree-view.lisp widgets.lisp 
Log Message:



--- /project/cells/cvsroot/cells-gtk/INSTALL.TXT	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/INSTALL.TXT	2008/01/28 23:59:24	1.1

To compile and run:

STEP 0: WINDOWS USERS: Do the stuff marked "Windows Users" below.

STEP .5: CLISP Users edit the path in ./load.lisp (you'll see it).

STEP 1: EVERYONE: Start lisp, change to this directory and do (load "load")

STEP 2: EVERYONE: (test-gtk::gtk-demo)

STEP 3: ANYONE (optional) make libcellsgtk, (or get it from the cells-gtk site). To make:
         3a) In ./root/gtk-ffi 'make' 
         3b) Move the library created to where it will be found (Linux see /etc/ld.so.conf).
         3c) Uncomment the line (pushnew :libcellsgtk *features*) in ./root/gtk-ffi/gtk-ffi.asd
         3d) Recompile the distribution (remove fasls and type (load "load") again.


TESTED ON:
    Windows XP: (with gtk 2.4.10) 
       AllegroCL 6.2 Enterprise, 
       Lispworks 4.3 Personal
    Windows 2000:
       CLISP 2.38
    Linux: 
      Lispworks 4.4 Pro, 
      CMUCL 19c, 
      CLISP 2.36
      SBCL 0.9.9.1

NOT TESTED SINCE SWITCHING TO CFFI: (as of 2006-01-03):
    AllegroCL
    MACOSX

;;; --------   Windows Users ---------------

Get GTK and Install

   http://gimp-win.sourceforge.net/stable.html  (I used version 2.8.9)
   
   Executing the setup.exe should add "C:\Program Files\Common Files\GTK\2.0\bin"
   to your path. You can verify that it has:

   Start>Settings>Control Panel>System>Advanced>Environment Variables>

   (I had to reboot after this, but then I don't know anything about Win32).

Note: On windows under emacs with slime, the gtk window does not popup. 
      You must start the application from a dos prompt. 
      (Solutions to this problem welcome!, probably involves putting something
       like a call to gtk-iteration-do into some slime loop through a hook.)

Known bugs:
    On Windows: Clisp crashes if    
    [My Computer]-> [Properties]-> [Advanced]-> [Perfomance Settings]-> [Show windows contents while dragging] 
    is set and resize the window while viewing a listbox or treebox.
--- /project/cells/cvsroot/cells-gtk/actions.lisp	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/actions.lisp	2008/01/28 23:59:24	1.1
(in-package :cgtk)

(def-object action ()
  ((name :accessor name :initarg :name :initform nil)
   (accel :accessor accel :initarg :accel :initform nil)
   (visible :accessor visible :initarg :visible :initform (c-in t))
   (sensitive :accessor sensitive :initarg :sensitive :initform (c-in t))
   (label :accessor label :initarg :label :initform nil)
   (tooltip :accessor tooltip :initarg :tooltip :initform nil)
   (stock :accessor stock :initarg :stock :initform nil)
   (stock-id :accessor stock-id :initform (c? (when (stock self)
						(string-downcase (format nil "gtk-~a" (stock self)))))))
  ()
  ()
  :new-args (c_1 (list (name self) nil nil (stock-id self))))

(def-c-output visible ((self action))
  (gtk-ffi::gtk-object-set-property (id self) "visible" 'boolean new-value))
(def-c-output sensitive ((self action))
  (gtk-ffi::gtk-object-set-property (id self) "sensitive" 'boolean new-value))

(def-c-output label ((self action))
  (when new-value
    (gtk-ffi::with-gtk-string (str new-value)
      (gtk-ffi::gtk-object-set-property (id self) "label" 'c-pointer str))))

(def-c-output tooltip ((self action))
  (when new-value
    (gtk-ffi::with-gtk-string (str new-value)      
      (gtk-ffi::gtk-object-set-property (id self) "tooltip" 'c-pointer str))))

(def-object action-group ()
  ((name :accessor name :initarg :name :initform nil)
   (visible :accessor visible :initarg :visible :initform (c-in t))
   (sensitive :accessor sensitive :initarg :sensitive :initform (c-in t)))
  ()
  ()
  :new-args (c_1 (list (name self))))

(def-c-output sensitive ((self action-group))
  (gtk-ffi::gtk-action-group-set-sensitive (id self) new-value))

(def-c-output visible ((self action-group))
  (gtk-ffi::gtk-action-group-set-visible (id self) new-value))

(def-c-output .kids ((self action-group))
  (dolist (kid old-value)
    (gtk-ffi::gtk-action-group-remove-action (id self) (id kid)))
  (dolist (kid new-value)
    (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid)))
  #+clisp (call-next-method))

(def-object ui-manager ()
  ((action-groups :accessor action-groups :initform (c-in nil))
   (add-tearoffs :accessor tearoffs :initarg :tearoffs :initform nil))
  ()
  ())

(def-c-output tearoffs ((self ui-manager))
  (gtk-ffi::gtk-ui-manager-set-add-tearoffs (id self) new-value))

(defmethod add-action-group ((self ui-manager) (group action-group) &optional pos)
  (let ((grp (to-be group)))
    (trc nil "ADD-ACTION-GROUP" grp) (force-output)
    (gtk-ffi::gtk-ui-manager-insert-action-group (id self) (id group) (or pos (length (action-groups self))))
    (push grp (action-groups self))))


(defmodel test-actions (vbox)
  ()
  (:default-initargs
      :action-group (mk-action-group 
                     :name "Group 1"
                     :kids (kids-list?
                            (mk-action
                             :name "Action 1" :stock :cdrom :label "Action 1" :accel "<Control>a")
                            (mk-action
                             :name "Action 2" :stock :network :label "Action 2" :accel "<Control>b")))
    
    :kids (kids-list?
           (mk-label :text "Actions test"))))
--- /project/cells/cvsroot/cells-gtk/addon.lisp	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/addon.lisp	2008/01/28 23:59:24	1.1
#|

 Cells Gtk

 Copyright (c) 2004 by Vasilis Margioulas <vasilism at sch.gr>

 You have the right to distribute and use this software as governed by 
 the terms of the Lisp Lesser GNU Public License (LLGPL):

    (http://opensource.franz.com/preamble.html)
 
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 Lisp Lesser GNU Public License for more details.
 
|#


(in-package :cgtk)

(def-widget calendar ()
  ((init :accessor init :initarg :init :initform nil)) 
  ()
  (day-selected)
  :on-day-selected (callback (widg signal data)
                     (setf (value self) (get-date self))))

(defmethod get-date ((self calendar))
  (uffi:with-foreign-objects ((year :int)(month :int)(day :int))
    (gtk-calendar-get-date (id self) year month day)
    (encode-universal-time 0 0 0 (uffi:deref-pointer day :int)
      (1+ (uffi:deref-pointer month :int)) (uffi:deref-pointer year :int))))

(defobserver init ((self calendar))
  (when new-value
    (multiple-value-bind (sec min hour day month year) (decode-universal-time new-value)
      
      (declare (ignorable sec min hour))
      (gtk-calendar-select-month (id self) (1- month) year)
      (gtk-calendar-select-day (id self) day))
    (setf (value self) new-value)))


(def-widget arrow ()
  ((type :accessor arrow-type :initarg :type :initform nil)
   (type-id :accessor type-id 
	    :initform (c? (case (arrow-type self)
			    (:up 0)
			    (:down 1)
			    (:left 2)
			    (:right 3)
			    (t 3))))
   (shadow :accessor arrow-shadow :initarg :shadow :initform nil)
   (shadow-id :accessor shadow-id
	      :initform (c? (case (arrow-shadow self)
			      (:none 0)
			      (:in 1)
			      (:out 2)
			      (:etched-in 3)
			      (:etched-out 4)
			      (t 2)))))
  ()
  ()
  :new-args (c_1 (list (type-id self) (shadow-id self))))

(defobserver type ((self arrow))
  (when new-value
    (gtk-arrow-set (id self) (type-id self) (shadow-id self))))

(defobserver shadow ((self arrow))
  (when new-value
    (gtk-arrow-set (id self) (type-id self) (shadow-id self))))

--- /project/cells/cvsroot/cells-gtk/asdf.lisp	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/asdf.lisp	2008/01/28 23:59:24	1.1
;;; This is asdf: Another System Definition Facility.  $Revision: 1.1 $
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list at lists.sf.net>.  But note first that the canonical
;;; source for asdf is presently the cCLan CVS repository at
;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'

;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;;; the problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it.  Hence, all in one file

(defpackage #:asdf
  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
	   #:system-definition-pathname #:find-component ; miscellaneous
	   #:hyperdocumentation #:hyperdoc
	   
	   #:compile-op #:load-op #:load-source-op #:test-system-version
	   #:test-op
	   #:operation			; operations
	   #:feature			; sort-of operation
	   #:version			; metaphorically sort-of an operation
	   
	   #:input-files #:output-files #:perform	; operation methods
	   #:operation-done-p #:explain
	   
	   #:component #:source-file 
	   #:c-source-file #:cl-source-file #:java-source-file
	   #:static-file
	   #:doc-file
	   #:html-file
	   #:text-file
	   #:source-file-type
	   #:module			; components
	   #:system
	   #:unix-dso
	   
	   #:module-components		; component accessors
	   #:component-pathname
	   #:component-relative-pathname
	   #:component-name
	   #:component-version
	   #:component-parent
	   #:component-property
	   #:component-system
	   
	   #:component-depends-on

	   #:system-description
	   #:system-long-description
	   #:system-author
	   #:system-maintainer
	   #:system-license
	   
	   #:operation-on-warnings
	   #:operation-on-failure
	   
	   ;#:*component-parent-pathname* 
	   #:*system-definition-search-functions*
	   #:*central-registry*		; variables
	   #:*compile-file-warnings-behaviour*
	   #:*compile-file-failure-behaviour*
	   #:*asdf-revision*
	   
	   #:operation-error #:compile-failed #:compile-warned #:compile-error
	   #:system-definition-error 
	   #:missing-component
	   #:missing-dependency
	   #:circular-dependency	; errors

	   #:retry
	   #:accept                     ; restarts
	   
	   )
  (:use :cl))

#+nil
(error "The author of this file habitually uses #+nil to comment out forms.  But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")


(in-package #:asdf)

(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $")
			       (colon (or (position #\: v) -1))
			       (dot (position #\. v)))
			  (and v colon dot 
			       (list (parse-integer v :start (1+ colon)
						    :junk-allowed t)
				     (parse-integer v :start (1+ dot)
						    :junk-allowed t)))))

(defvar *compile-file-warnings-behaviour* :warn)
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)

(defvar *verbose-out* nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff

(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

(defun pathname-sans-name+type (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME and TYPE components"
  (make-pathname :name nil :type nil :defaults pathname))

(define-modify-macro appendf (&rest args) 
		     append "Append onto list") 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; classes, condiitons

(define-condition system-definition-error (error) ()
  ;; [this use of :report should be redundant, but unfortunately it's not.
  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
  ;; over print-object; this is always conditions::%print-condition for
  ;; condition objects, which in turn does inheritance of :report options at
  ;; run-time.  fortunately, inheritance means we only need this kludge here in
  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
  #+cmu (:report print-object))

(define-condition formatted-system-definition-error (system-definition-error)
  ((format-control :initarg :format-control :reader format-control)
   (format-arguments :initarg :format-arguments :reader format-arguments))
  (:report (lambda (c s)
	     (apply #'format s (format-control c) (format-arguments c)))))

(define-condition circular-dependency (system-definition-error)
  ((components :initarg :components :reader circular-dependency-components)))

(define-condition missing-component (system-definition-error)
  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
   (version :initform nil :reader missing-version :initarg :version)
   (parent :initform nil :reader missing-parent :initarg :parent)))

(define-condition missing-dependency (missing-component)
  ((required-by :initarg :required-by :reader missing-required-by)))

(define-condition operation-error (error)
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
	     (format s "~@<erred while invoking ~A on ~A~@:>"
		     (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())

(defclass component ()
  ((name :accessor component-name :initarg :name :documentation
	 "Component name: designator for a string composed of portable pathname characters")
   (version :accessor component-version :initarg :version)
   (in-order-to :initform nil :initarg :in-order-to)
   ;;; XXX crap name
   (do-first :initform nil :initarg :do-first)
   ;; methods defined using the "inline" style inside a defsystem form:
   ;; need to store them somewhere so we can delete them when the system
   ;; is re-evaluated
   (inline-methods :accessor component-inline-methods :initform nil)
   (parent :initarg :parent :initform nil :reader component-parent)
   ;; no direct accessor for pathname, we do this as a method to allow

[920 lines skipped]
--- /project/cells/cvsroot/cells-gtk/buttons.lisp	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/buttons.lisp	2008/01/28 23:59:24	1.1

[1023 lines skipped]
--- /project/cells/cvsroot/cells-gtk/callback.lisp	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/callback.lisp	2008/01/28 23:59:24	1.1

[1062 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cells-gtk.asd	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/cells-gtk.asd	2008/01/28 23:59:24	1.1

[1085 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cells-gtk.lpr	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/cells-gtk.lpr	2008/01/28 23:59:24	1.1

[1135 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cells3-porting-notes.lisp	2008/01/28 23:59:24	NONE
+++ /project/cells/cvsroot/cells-gtk/cells3-porting-notes.lisp	2008/01/28 23:59:24	1.1

[1166 lines skipped]
--- /project/cells/cvsroot/cells-gtk/clisp.bat	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/clisp.bat	2008/01/28 23:59:25	1.1

[1168 lines skipped]
--- /project/cells/cvsroot/cells-gtk/compat.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/compat.lisp	2008/01/28 23:59:25	1.1

[1212 lines skipped]
--- /project/cells/cvsroot/cells-gtk/conditions.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/conditions.lisp	2008/01/28 23:59:25	1.1

[1250 lines skipped]
--- /project/cells/cvsroot/cells-gtk/dialogs.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/dialogs.lisp	2008/01/28 23:59:25	1.1

[1402 lines skipped]
--- /project/cells/cvsroot/cells-gtk/display.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/display.lisp	2008/01/28 23:59:25	1.1

[1557 lines skipped]
--- /project/cells/cvsroot/cells-gtk/drawing.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/drawing.lisp	2008/01/28 23:59:25	1.1

[1779 lines skipped]
--- /project/cells/cvsroot/cells-gtk/entry.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/entry.lisp	2008/01/28 23:59:25	1.1

[1932 lines skipped]
--- /project/cells/cvsroot/cells-gtk/gtk-app-save.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/gtk-app-save.lisp	2008/01/28 23:59:25	1.1

[2087 lines skipped]
--- /project/cells/cvsroot/cells-gtk/gtk-app-win32.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/gtk-app-win32.lisp	2008/01/28 23:59:25	1.1

[2252 lines skipped]
--- /project/cells/cvsroot/cells-gtk/gtk-app.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/gtk-app.lisp	2008/01/28 23:59:25	1.1

[2408 lines skipped]
--- /project/cells/cvsroot/cells-gtk/layout.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/layout.lisp	2008/01/28 23:59:25	1.1

[2705 lines skipped]
--- /project/cells/cvsroot/cells-gtk/lisp.bat	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/lisp.bat	2008/01/28 23:59:25	1.1

[2707 lines skipped]
--- /project/cells/cvsroot/cells-gtk/load.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/load.lisp	2008/01/28 23:59:25	1.1

[2754 lines skipped]
--- /project/cells/cvsroot/cells-gtk/menus.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/menus.lisp	2008/01/28 23:59:25	1.1

[3055 lines skipped]
--- /project/cells/cvsroot/cells-gtk/packages.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/packages.lisp	2008/01/28 23:59:25	1.1

[3131 lines skipped]
--- /project/cells/cvsroot/cells-gtk/pod-notes.txt	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/pod-notes.txt	2008/01/28 23:59:25	1.1

[3270 lines skipped]
--- /project/cells/cvsroot/cells-gtk/textview.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/textview.lisp	2008/01/28 23:59:25	1.1

[3430 lines skipped]
--- /project/cells/cvsroot/cells-gtk/tree-view.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/tree-view.lisp	2008/01/28 23:59:25	1.1

[3700 lines skipped]
--- /project/cells/cvsroot/cells-gtk/widgets.lisp	2008/01/28 23:59:25	NONE
+++ /project/cells/cvsroot/cells-gtk/widgets.lisp	2008/01/28 23:59:25	1.1

[4099 lines skipped]



More information about the Cells-cvs mailing list