From ktilton at common-lisp.net Mon Jan 28 23:52:26 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:52:26 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080128235226.454876918E@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv8370 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Mon Jan 28 23:56:12 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:12 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi Message-ID: <20080128235612.1B1546919A@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi In directory clnet:/tmp/cvs-serv8760/cffi Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:12 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:12 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/gtk-ffi Message-ID: <20080128235612.7928F6919A@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/gtk-ffi In directory clnet:/tmp/cvs-serv8760/gtk-ffi Log Message: Directory /project/cells/cvsroot/cells-gtk/gtk-ffi added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:12 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:12 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/pod-utils Message-ID: <20080128235612.D441D6919A@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/pod-utils In directory clnet:/tmp/cvs-serv8760/pod-utils Log Message: Directory /project/cells/cvsroot/cells-gtk/pod-utils added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:14 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:14 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/public_html Message-ID: <20080128235614.A65191603F@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/public_html In directory clnet:/tmp/cvs-serv8760/public_html Log Message: Directory /project/cells/cvsroot/cells-gtk/public_html added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:15 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:15 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/root Message-ID: <20080128235615.4DA047E01C@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/root In directory clnet:/tmp/cvs-serv8760/root Log Message: Directory /project/cells/cvsroot/cells-gtk/root added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:15 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:15 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/test-gtk Message-ID: <20080128235615.DE9607E026@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv8760/test-gtk Log Message: Directory /project/cells/cvsroot/cells-gtk/test-gtk added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:16 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:16 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/test-images Message-ID: <20080128235616.4F9597E021@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/test-images In directory clnet:/tmp/cvs-serv8760/test-images Log Message: Directory /project/cells/cvsroot/cells-gtk/test-images added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:32 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:32 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/doc Message-ID: <20080128235632.A363B490A7@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/doc In directory clnet:/tmp/cvs-serv8901/doc Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi/doc added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:34 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:34 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/examples Message-ID: <20080128235634.2BCC271138@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/examples In directory clnet:/tmp/cvs-serv8901/examples Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi/examples added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:35 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:35 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/scripts Message-ID: <20080128235635.A160C74016@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/scripts In directory clnet:/tmp/cvs-serv8901/scripts Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi/scripts added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:36 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:36 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/src Message-ID: <20080128235636.C54447C05D@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/src In directory clnet:/tmp/cvs-serv8901/src Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi/src added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:38 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:38 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/tests Message-ID: <20080128235638.B7E5174016@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/tests In directory clnet:/tmp/cvs-serv8901/tests Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi/tests added to the repository From ktilton at common-lisp.net Mon Jan 28 23:56:40 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:56:40 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/uffi-compat Message-ID: <20080128235640.5CDF6490AD@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/uffi-compat In directory clnet:/tmp/cvs-serv8901/uffi-compat Log Message: Directory /project/cells/cvsroot/cells-gtk/cffi/uffi-compat added to the repository From ktilton at common-lisp.net Mon Jan 28 23:59:25 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:25 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080128235925.62CE37C05D@common-lisp.net> 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 "a") (mk-action :name "Action 2" :stock :network :label "Action 2" :accel "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 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 ;;; . But note first that the canonical ;;; source for asdf is presently the cCLan CVS repository at ;;; ;;; ;;; 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 "~@" (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] From ktilton at common-lisp.net Mon Jan 28 23:59:26 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:26 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi Message-ID: <20080128235926.2E9147C05D@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi In directory clnet:/tmp/cvs-serv9292/cffi Added Files: COPYRIGHT HEADER Makefile README TODO cffi-examples.asd cffi-tests.asd cffi-uffi-compat.asd cffi.asd cffi.lpr Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/COPYRIGHT 2008/01/28 23:59:25 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/COPYRIGHT 2008/01/28 23:59:25 1.1 Copyright (C) 2005-2006, James Bielman 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. --- /project/cells/cvsroot/cells-gtk/cffi/HEADER 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/HEADER 2008/01/28 23:59:26 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; filename --- description ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; --- /project/cells/cvsroot/cells-gtk/cffi/Makefile 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/Makefile 2008/01/28 23:59:26 1.1 # -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- # # Makefile --- Make targets for various tasks. # # Copyright (C) 2005-2006, James Bielman # # 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. # # This way you can easily run the tests for different versions # of each lisp with, e.g. ALLEGRO=/path/to/some/lisp make test-allegro CMUCL ?= lisp OPENMCL ?= openmcl SBCL ?= sbcl CLISP ?= clisp ALLEGRO ?= acl SCL ?= scl shlibs: @$(MAKE) -wC tests shlibs clean: @$(MAKE) -wC tests clean find . -name ".fasls" | xargs rm -rf find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.amd64f" -o -name "*.sparcf" -o -name "*.sparc64f" -o -name "*.hpf" -o -name "*.hp64f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" -o -name "*.lx64fsl" \) -exec rm {} \; test-openmcl: @-$(OPENMCL) --load tests/run-tests.lisp test-sbcl: @-$(SBCL) --noinform --load tests/run-tests.lisp test-cmucl: @-$(CMUCL) -load tests/run-tests.lisp test-scl: @-$(SCL) -load tests/run-tests.lisp test-clisp: @-$(CLISP) -q -x '(load "tests/run-tests.lisp")' test-clisp-modern: @-$(CLISP) -modern -q -x '(load "tests/run-tests.lisp")' test-allegro: @-$(ALLEGRO) -L tests/run-tests.lisp test: test-openmcl test-sbcl test-cmucl test-clisp # vim: ft=make ts=3 noet --- /project/cells/cvsroot/cells-gtk/cffi/README 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/README 2008/01/28 23:59:26 1.1 CFFI, the Common Foreign Function Interface, purports to be a portable foreign function interface, similar in spirit to UFFI. Unlike UFFI, CFFI requires only a small set of low-level functionality from the Lisp implementation, such as calling a foreign function by name, allocating foreign memory, and dereferencing pointers. More complex tasks like accessing foreign structures can be done in portable "user space" code, making use of the low-level memory access operations defined by the implementation-specific bits. CFFI also aims to be more efficient than UFFI when possible. In particular, UFFI's use of aliens in CMUCL and SBCL can be tricky to get right. CFFI avoids this by using system area pointers directly instead of alien objects. All foreign function definitions and uses should compile without alien-value compiler notes in CMUCL/SBCL. --- /project/cells/cvsroot/cells-gtk/cffi/TODO 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/TODO 2008/01/28 23:59:26 1.1 -*- Text -*- This is a collection of TODO items and ideas in no particular order. ### Testing -> Test uffi-compat with more UFFI libraries. -> Write more FOREIGN-GLOBALS.SET.* tests. -> Finish tests/random-tester.lisp -> Write benchmarks comparing CFFI vs. native FFIs and also demonstrating performance of each platform. -> Write more STRUCT.ALIGNMENT.* tests (namely involving the :LONG-LONG and :UNSIGNED-LONG-LONG types) and test them in more ABIs. -> Run tests both interpreted (where it makes sense) and compiled. -> Run tests with the different kinds of shared libraries available on MacOS X. ### Ports -> Finish GCL port. -> As of 2006-06-27, CVS ECL fails 31 tests on linux/x86 and 35 tests on darwin/ppc. Need to look into this. -> Fix bugs in the Corman port. -> Port to MCL. ### Features -> Implement CFFI-SYS:%CLOSE-FOREIGN-LIBRARY for all supported Lisps and implement a higher-level CFFI:CLOSE-FOREIGN-LIBRARY. -> Implement a declarative interface for FOREIGN-FUNCALL-PTR, similar to DEFCUN/FOREIGN-FUNCALL. -> Figure out how to portably define types like: time_t, size_t, wchar_t, etc... Likely to involve something like SB-GROVEL and possibly avoiding this step on known platforms? -> [Lost Idea] Something involving finalizers? -> Implement the proposed interfaces (see doc/). -> Add the ability to specify the calling convention to the interface. -> Implement CFFI-SYS:ERRNO-VALUE (name?). -> Extend FOREIGN-SLOT-VALUE and make it accept multiple "indices" for directly accessing structs inside structs, arrays inside structs, etc... -> Implement EXPLAIN-FOREIGN-SLOT-VALUE. -> Implement :in/:out/:in-out for DEFCFUN (and FOREIGN-FUNCALL?). -> Add support for multiple memory allocation schemes (like CLISP), namely support for allocating with malloc() (so that it can be freed on the C side)> -> Extend DEFCVAR's symbol macro in order to handle memory (de)allocation automatically (see CLISP). -> Implement byte swapping routines (see /usr/include/linux/byteorder) -> [Lost Idea] Implement UB8-REF? -> [Lost Idea] Something about MEM-READ-C-STRING returning multiple value? -> Implement an array type? Useful when we're working with ranks >= 2? -> Implement bitfields. To read: get the word, LDB it. To write: get the word, PDB it, put the word. -> External encodings for the :STRING type. See: -> Define a lisp type for pointers in the backends. Eg: for clisp: (deftype pointer-type (or ffi:foreign-address null)) Useful for type declarations. -> Warn about :void in places where it doesn't make sense. ### Underspecified Semantics -> (setf (mem-ref ptr offset) ) -> Review the interface for coherence across Lisps with regard to behaviour in "exceptional" situations. Eg: threads, dumping cores, accessing foreign symbols that don't exist, etc... -> On Lispworks a Lisp float is a double and therefore won't necessarily fit in a C float. Figure out a way to handle this. -> Allegro: callbacks' return values. -> Lack of uniformity with regard to pointers. Allegro: 0 -> NULL. CLISP/Lispworks: NIL -> NULL. -> Some lisps will accept a lisp float being passed to :double and a lisp double to :float. We should either coerce on lisps that don't accept this or check-type on lisps that do. Probably the former is better since on lispworks/x86 double == float. -> What happens when the same library is loaded twice. ### Possible Optimizations -> More compiler macros on some of the CFFI-SYS implementations. -> Optimize UFFI-COMPAT when the vector stuff is implemented. -> Being able to declare that some C int will always fit in a Lisp fixnum. Allegro has a :fixnum ftype and CMUCL/SBCL can use (unsigned-byte 29) others could perhaps behave like :int? -> An option for defcfun to expand into a compiler macro which would allow the macroexpansion-time translators to look at the forms passed to the functions. ### Known Issues -> CLISP FASL portability is broken. Fix this by placing LOAD-TIME-VALUE forms in the right places and moving other calculations to load-time. (eg: calculating struct size/alignment.) Ideally we'd only move them to load-time when we actually care about fasl portability. (defmacro maybe-load-time-value (form) (if `(load-time-value ,form) form)) -> cffi-tests.asd's :c-test-lib component is causing the whole testsuite to be recompiled everytime. Figure that out. -> The (if (constantp foo) (do-something-with (eval foo)) ...) pattern used in many places throughout the code is apparently not 100% safe. -> On ECL platforms without DFFI we need to build a non-linked version of libtest. ### Documentation -> Fill the missing sections in the CFFI User Manual. -> Update the CFFI-SYS Specification. -> Generally improve the reference docs and examples. ### Other -> Type-checking pointer interface. --- /project/cells/cvsroot/cells-gtk/cffi/cffi-examples.asd 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/cffi-examples.asd 2008/01/28 23:59:26 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-examples.asd --- ASDF system definition for CFFI examples. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; (defpackage #:cffi-examples-system (:use #:cl #:asdf)) (in-package #:cffi-examples-system) (defsystem cffi-examples :description "CFFI Examples" :author "James Bielman " :components ((:module examples :components ((:file "examples") (:file "gethostname") (:file "gettimeofday")))) :depends-on (cffi)) --- /project/cells/cvsroot/cells-gtk/cffi/cffi-tests.asd 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/cffi-tests.asd 2008/01/28 23:59:26 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-tests.asd --- ASDF system definition for CFFI unit tests. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; (defpackage #:cffi-tests-system (:use #:cl #:asdf)) (in-package #:cffi-tests-system) (defvar *tests-dir* (append (pathname-directory *load-truename*) '("tests"))) (defclass c-test-lib (c-source-file) ()) (defmethod perform ((o load-op) (c c-test-lib)) nil) (defmethod perform ((o load-source-op) (c c-test-lib)) nil) (defmethod perform ((o compile-op) (c c-test-lib)) #-(or win32 mswindows) (unless (zerop (run-shell-command #-freebsd "cd ~A; make" #+freebsd "cd ~A; gmake" (namestring (make-pathname :name nil :type nil :directory *tests-dir*)))) (error 'operation-error :component c :operation o))) (defsystem cffi-tests :description "Unit tests for CFFI." :depends-on (cffi rt) :components ((:module "tests" :serial t :components ((:c-test-lib "libtest") (:file "package") (:file "bindings") (:file "funcall") (:file "defcfun") (:file "callbacks") (:file "foreign-globals") (:file "memory") (:file "struct") (:file "union") (:file "enum") (:file "misc-types") (:file "misc"))))) (defun run-cffi-tests (&key (compiled nil)) (funcall (intern (symbol-name '#:run-cffi-tests) '#:cffi-tests) :compiled compiled)) (defmethod perform ((o test-op) (c (eql (find-system :cffi-tests)))) (unless (and (run-cffi-tests :compiled nil) (run-cffi-tests :compiled t)) (error "test-op failed."))) ;;; vim: ft=lisp et --- /project/cells/cvsroot/cells-gtk/cffi/cffi-uffi-compat.asd 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/cffi-uffi-compat.asd 2008/01/28 23:59:26 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-uffi-compat.asd --- ASDF system definition for CFFI-UFFI-COMPAT. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; (defpackage #:cffi-uffi-compat-system (:use #:cl #:asdf)) [12 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/cffi.asd 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/cffi.asd 2008/01/28 23:59:26 1.1 [80 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/cffi.lpr 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/cffi.lpr 2008/01/28 23:59:26 1.1 [178 lines skipped] From ktilton at common-lisp.net Mon Jan 28 23:59:26 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:26 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/doc Message-ID: <20080128235926.085187C061@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/doc In directory clnet:/tmp/cvs-serv9292/cffi/doc Added Files: Makefile allegro-internals.txt cffi-manual.texinfo cffi-sys-spec.texinfo colorize-lisp-examples.lisp gendocs.sh gendocs_template mem-vector.txt shareable-vectors.txt style.css Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/doc/Makefile 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/Makefile 2008/01/28 23:59:26 1.1 # -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- # # Makefile --- Make targets for generating the documentation. # # Copyright (C) 2005-2006, Luis Oliveira # # 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. # all: docs docs: sh gendocs.sh -o manual --html "--css-include=style.css" cffi-manual "CFFI User Manual" sh gendocs.sh -o spec --html "--css-include=style.css" cffi-sys-spec "CFFI-SYS Interface Specification" clean: find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; rm -rf manual spec upload-docs: rsync -av --delete -e ssh manual spec common-lisp.net:/project/cffi/public_html/ # scp -r manual spec common-lisp.net:/project/cffi/public_html/ # vim: ft=make ts=3 noet --- /project/cells/cvsroot/cells-gtk/cffi/doc/allegro-internals.txt 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/allegro-internals.txt 2008/01/28 23:59:26 1.1 July 2005 These details were kindly provided by Duane Rettig of Franz. Regarding the following snippet of the macro expansion of FF:DEF-FOREIGN-CALL: (SYSTEM::FF-FUNCALL (LOAD-TIME-VALUE (EXCL::DETERMINE-FOREIGN-ADDRESS '("foo" :LANGUAGE :C) 2 NIL)) '(:INT (INTEGER * *)) ARG1 '(:DOUBLE (DOUBLE-FLOAT * *)) ARG2 '(:INT (INTEGER * *))) " ... in Allegro CL, if you define a foreign call FOO with C entry point "foo" and with :call-direct t in the arguments, and if other things are satisfied, then if a lisp function BAR is compiled which has a call to FOO, that call will not go through ff-funcall (and thus a large amount of argument manipulation and processing) but will instead set up its arguments directly on the stack, and will then perform the "call" more or less directly, through the "entry vec" (a small structure which keeps track of a foreign entry's address and status)." This is the code that generates what the compiler expects to see: (setq call-direct-form (if* call-direct then `(setf (get ',lispname 'sys::direct-ff-call) (list ',external-name ,callback ,convention ',returning ',arg-types ,arg-checking ,entry-vec-flags)) else `(remprop ',lispname 'sys::direct-ff-call))) Thus generating something like: (EVAL-WHEN (COMPILE LOAD EVAL) (SETF (GET 'FOO 'SYSTEM::DIRECT-FF-CALL) (LIST '("foo" :LANGUAGE :C) T :C '(:INT (INTEGER * *)) '((:INT (INTEGER * *)) (:FLOAT (SINGLE-FLOAT * *))) T 2 ; this magic value is explained later ))) " (defun determine-foreign-address (name &optional (flags 0) method-index) ;; return an entry-vec struct suitable for the foreign-call of name. ;; ;; name is either a string, which is taken without conversion, or ;; a list consisting of a string to convert or a conversion function ;; call. ;; flags is an integer representing the flags to place into the entry-vec. ;; method-index, if non-nil, is a word-index into a vtbl (virtual table). ;; If method-index is true, then the name must be a string uniquely ;; represented by the index and by the flags field. Note that not all architectures implement the :method-index argument to def-foreign-call, but your interface likely won't support it anyway, so just leave it nil. As for the flags, they are constants stored into the entry-vec returned by d-f-a and are given here: (defconstant ep-flag-call-semidirect 1) ; Real address stored in alt-address slot (defconstant ep-flag-never-release 2) ; Never release the heap (defconstant ep-flag-always-release 4) ; Always release the heap (defconstant ep-flag-release-when-ok 8) ; Release the heap unless without-interrupts (defconstant ep-flag-tramp-calls #x70) ; Make calls through special trampolines (defconstant ep-flag-tramp-shift 4) (defconstant ep-flag-variable-address #x100) ; Entry-point contains address of C var (defconstant ep-flag-strings-convert #x200) ; Convert strings automatically (defconstant ep-flag-get-errno #x1000) ;; [rfe5060]: Get errno value after call (defconstant ep-flag-get-last-error #x2000) ;; [rfe5060]: call GetLastError after call ;; Leave #x4000 and #x8000 open for expansion Mostly, you'll give the value 2 (never release the heap), but if you give 4 or 8, then d-f-a will automatically set the 1 bit as well, which takes the call through a heap-release/reacquire process. Some docs for entry-vec are: ;; -- entry vec -- ;; An entry-vec is an entry-point descriptor, usually a pointer into ;; a shared-library. It is represented as a 5-element struct of type ;; foreign-vector. The reason for this represntation is ;; that it allows the entry point to be stored in a table, called ;; the .saved-entry-points. table, and to be used by a foreign ;; function. When the location of the foreign function to which the entry ;; point refers changes, it is simply a matter of changing the value in entry ;; point vector and the foreign call code sees it immediately. There is ;; even an address that can be put in the entry point vector that denotes ;; a missing foreign function, thus lookup can happen dynamically. (defstruct (entry-vec (:type (vector excl::foreign (*))) (:constructor make-entry-vec-boa ())) name ; entry point name (address 0) ; jump address for foreign code (handle 0) ; shared-lib handle (flags 0) ; ep-* flags (alt-address 0) ; sometimes holds the real func addr ) [...] " Regarding the arguments to SYSTEM::FF-FUNCALL: '(:int (integer * *)) argN "The type-spec is as it is given in the def-foreign-call syntax, with a C type optionally followed by a lisp type, followed optionally by a user-conversion function name[...]" Getting the alignment: CL-USER(2): (ff:get-foreign-type :int) #S(FOREIGN-FUNCTIONS::IFOREIGN-TYPE :ATTRIBUTES NIL :SFTYPE #S(FOREIGN-FUNCTIONS::SIZED-FTYPE-PRIM :KIND :INT :WIDTH 4 :OFFSET 0 :ALIGN 4) ...) --- /project/cells/cvsroot/cells-gtk/cffi/doc/cffi-manual.texinfo 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/cffi-manual.texinfo 2008/01/28 23:59:26 1.1 \input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*- @c %**start of header @setfilename cffi.info @settitle CFFI User Manual @exampleindent 2 @c @documentencoding utf-8 @ignore Style notes: * The reference section names and "See Also" list are roman, not @code. This is to follow the format of CLHS. * How it looks in HTML is the priority. @end ignore @c ============================= Macros ============================= @c The following macros are used throughout this manual. @macro Function {args} @defun \args\ @end defun @end macro @macro Macro {args} @defmac \args\ @end defmac @end macro @macro Accessor {args} @deffn {Accessor} \args\ @end deffn @end macro @macro GenericFunction {args} @deffn {Generic Function} \args\ @end deffn @end macro @macro ForeignType {args} @deftp {Foreign Type} \args\ @end deftp @end macro @macro Variable {args} @defvr {Special Variable} \args\ @end defvr @end macro @macro Condition {args} @deftp {Condition Type} \args\ @end deftp @end macro @macro cffi @acronym{CFFI} @end macro @macro impnote {text} @quotation @strong{Implementor's note:} @emph{\text\} @end quotation @end macro @c Info "requires" that x-refs end in a period or comma, or ) in the @c case of @pxref. So the following implements that requirement for @c the "See also" subheadings that permeate this manual, but only in @c Info mode. @ifinfo @macro seealso {name} @ref{\name\}. @end macro @end ifinfo @ifnotinfo @alias seealso = ref @end ifnotinfo @c Set ROMANCOMMENTS to get comments in roman font. @ifset ROMANCOMMENTS @alias lispcmt = r @end ifset @ifclear ROMANCOMMENTS @alias lispcmt = asis @end ifclear @c ============================= Macros ============================= @c Show types, functions, and concepts in the same index. @syncodeindex tp cp @syncodeindex fn cp @copying Copyright @copyright{} 2005 James Bielman @* Copyright @copyright{} 2005, 2006 Lu@'{@dotless{i}}s Oliveira @* Copyright @copyright{} 2006 Stephen Compall @quotation 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. @sc{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.} @end quotation @end copying @c %**end of header @titlepage @title CFFI User Manual @c @subtitle Version X.X @c @author James Bielman @page @vskip 0pt plus 1filll @insertcopying @end titlepage @contents @ifnottex @node Top @top cffi @insertcopying @end ifnottex @menu * Introduction:: What is CFFI? * Implementation Support:: * Tutorial:: Interactive intro to using CFFI. * Wrapper generators:: CFFI forms from munging C source code. * Foreign Types:: * Pointers:: * Strings:: * Variables:: * Functions:: * Libraries:: * Callbacks:: * Finalizers:: * Limitations:: * Platform-specific features:: Details about the underlying system. * Glossary:: List of CFFI-specific terms and meanings. * Comprehensive Index:: @detailmenu --- Dictionary --- Foreign Types * convert-from-foreign:: Outside interface to backward type translator. * convert-to-foreign:: Outside interface to forward type translator. * defbitfield:: Defines a bitfield. * defcstruct:: Defines a C structure type. * defcunion:: Defines a C union type. * defctype:: Defines a foreign typedef. * defcenum:: Defines a C enumeration. @c * define-type-spec-parser:: * define-foreign-type:: Defines a foreign type specifier. @c * explain-foreign-slot-value:: * foreign-bitfield-symbols:: Returns a list of symbols for a bitfield type. * foreign-bitfield-value:: Calculates a value for a bitfield type. * foreign-enum-keyword:: Finds a keyword in an enum type. * foreign-enum-value:: Finds a value in an enum type. * foreign-slot-names:: Returns a list of slot names in a foreign struct. * foreign-slot-offset:: Returns the offset of a slot in a foreign struct. * foreign-slot-pointer:: Returns a pointer to a slot in a foreign struct. * foreign-slot-value:: Returns the value of a slot in a foreign struct. * foreign-type-alignment:: Returns the alignment of a foreign type. * foreign-type-size:: Returns the size of a foreign type. * free-converted-object:: Outside interface to typed object deallocators. * free-translated-object:: Free a type translated foreign object. * translate-from-foreign:: Translate a foreign object to a Lisp object. * translate-to-foreign:: Translate a Lisp object to a foreign object. * with-foreign-object:: Allocates a foreign object with dynamic extent. * with-foreign-slots:: Access the slots of a foreign structure. Pointers * foreign-free:: Deallocates memory. * foreign-alloc:: Allocates memory. * foreign-symbol-pointer:: Returns a pointer to a foreign symbol. * inc-pointer:: Increments the address held by a pointer. * make-pointer:: Returns a pointer to a given address. * mem-aref:: Accesses the value of an index in an array. * mem-ref:: Dereferences a pointer. * null-pointer:: Returns a NULL pointer. * null-pointer-p:: Tests a pointer for NULL value. * pointerp:: Tests whether an object is a pointer or not. * pointer-address:: Returns the address pointed to by a pointer. * pointer-eq:: Tests if two pointers point to the same address. * with-foreign-pointer:: Allocates memory with dynamic extent. Strings * foreign-string-alloc:: Converts a Lisp string to a foreign string. * foreign-string-free:: Deallocates memory used by a foreign string. * foreign-string-to-lisp:: Converts a foreign string to a Lisp string. * lisp-string-to-foreign:: Copies a Lisp string into a foreign string. * with-foreign-string:: Allocates a foreign string with dynamic extent. * with-foreign-pointer-as-string:: Similar to CL's with-output-to-string. Variables * defcvar:: Defines a C global variable. * get-var-pointer:: Returns a pointer to a defined global variable. Functions * defcfun:: Defines a foreign function. * foreign-funcall:: Performs a call to a foreign function. [5407 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/cffi-sys-spec.texinfo 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/cffi-sys-spec.texinfo 2008/01/28 23:59:26 1.1 [5718 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/colorize-lisp-examples.lisp 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/colorize-lisp-examples.lisp 2008/01/28 23:59:26 1.1 [6769 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/gendocs.sh 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/gendocs.sh 2008/01/28 23:59:26 1.1 [7079 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/gendocs_template 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/gendocs_template 2008/01/28 23:59:26 1.1 [7338 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/mem-vector.txt 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/mem-vector.txt 2008/01/28 23:59:26 1.1 [7413 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/shareable-vectors.txt 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/shareable-vectors.txt 2008/01/28 23:59:26 1.1 [7457 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/doc/style.css 2008/01/28 23:59:26 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/doc/style.css 2008/01/28 23:59:26 1.1 [7505 lines skipped] From ktilton at common-lisp.net Mon Jan 28 23:59:28 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:28 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/examples Message-ID: <20080128235928.1CF844F01A@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/examples In directory clnet:/tmp/cvs-serv9292/cffi/examples Added Files: examples.lisp gethostname.lisp gettimeofday.lisp run-examples.lisp translator-test.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/examples/examples.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/examples.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; examples.lisp --- Simple test examples of CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; (defpackage #:cffi-examples (:use #:cl #:cffi) (:export #:run-examples #:sqrtf #:getenv)) (in-package #:cffi-examples) ;; A simple libc function. (defcfun "sqrtf" :float (n :float)) ;; This definition uses the STRING type translator to automatically ;; convert Lisp strings to foreign strings and vice versa. (defcfun "getenv" :string (name :string)) ;; Calling a varargs function. (defun sprintf-test () "Test calling a varargs function." (with-foreign-pointer-as-string (buf 255 buf-size) (foreign-funcall "snprintf" :pointer buf :int buf-size :string "%d %f #x%x!" :int 666 :double (coerce pi 'double-float) :unsigned-int #xcafebabe :void))) ;; Defining an emerated type. (defcenum test-enum (:invalid 0) (:positive 1) (:negative -1)) ;; Use the absolute value function to test keyword/enum translation. (defcfun ("abs" c-abs) test-enum (n test-enum)) (defun cffi-version () (asdf:component-version (asdf:find-system 'cffi))) (defun run-examples () (format t "~&;;; CFFI version ~A on ~A ~A:~%" (cffi-version) (lisp-implementation-type) (lisp-implementation-version)) (format t "~&;; shell: ~A~%" (getenv "SHELL")) (format t "~&;; sprintf test: ~A~%" (sprintf-test)) (format t "~&;; (c-abs :positive): ~A~%" (c-abs :positive)) (format t "~&;; (c-abs :negative): ~A~%" (c-abs :negative)) (force-output)) --- /project/cells/cvsroot/cells-gtk/cffi/examples/gethostname.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/gethostname.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; gethostname.lisp --- A simple CFFI example. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; ;;;# CFFI Example: gethostname binding ;;; ;;; This is a very simple CFFI example that illustrates calling a C ;;; function that fills in a user-supplied string buffer. (defpackage #:cffi-example-gethostname (:use #:common-lisp #:cffi) (:export #:gethostname)) (in-package #:cffi-example-gethostname) ;;; Define the Lisp function %GETHOSTNAME to call the C 'gethostname' ;;; function, which will fill BUF with up to BUFSIZE characters of the ;;; system's hostname. (defcfun ("gethostname" %gethostname) :int (buf :pointer) (bufsize :int)) ;;; Define a Lispy interface to 'gethostname'. The utility macro ;;; WITH-FOREIGN-POINTER-AS-STRING is used to allocate a temporary ;;; buffer and return it as a Lisp string. (defun gethostname () (with-foreign-pointer-as-string (buf 255 bufsize) (%gethostname buf bufsize))) --- /project/cells/cvsroot/cells-gtk/cffi/examples/gettimeofday.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/gettimeofday.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2) ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; ;;;# CFFI Example: gettimeofday binding ;;; ;;; This example illustrates the use of foreign structures, typedefs, ;;; and using type translators to do checking of input and output ;;; arguments to a foreign function. (defpackage #:cffi-example-gettimeofday (:use #:common-lisp #:cffi #:cffi-utils) (:export #:gettimeofday)) (in-package #:cffi-example-gettimeofday) ;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes ;;; that 'time_t' is a 'long' --- it would be nice if CFFI could ;;; provide a proper :TIME-T type to help make this portable. (defcstruct timeval (tv-sec :long) (tv-usec :long)) ;;; A NULL-POINTER is a foreign :POINTER that must always be NULL. ;;; Both a NULL pointer and NIL are legal values---any others will ;;; result in a runtime error. (defctype null-pointer :pointer) ;;; This type translator is used to ensure that a NULL-POINTER has a ;;; null value. It also converts NIL to a null pointer. (defmethod translate-to-foreign (value (name (eql 'null-pointer))) (cond ((null value) (null-pointer)) ((null-pointer-p value) value) (t (error "~A is not a null pointer." value)))) ;;; The SYSCALL-RESULT type is an integer type used for the return ;;; value of C functions that return -1 and set errno on errors. ;;; Someday when CFFI has a portable interface for dealing with ;;; 'errno', this error reporting can be more useful. (defctype syscall-result :int) ;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error ;;; if the value is negative. (defmethod translate-from-foreign (value (name (eql 'syscall-result))) (if (minusp value) (error "System call failed with return value ~D." value) value)) ;;; Define the Lisp function %GETTIMEOFDAY to call the C function ;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill ;;; in. The TZP parameter is deprecated and should be NULL --- we can ;;; enforce this by using our NULL-POINTER type defined above. (defcfun ("gettimeofday" %gettimeofday) syscall-result (tp :pointer) (tzp null-pointer)) ;;; Define a Lispy interface to 'gettimeofday' that returns the ;;; seconds and microseconds as multiple values. (defun gettimeofday () (with-foreign-object (tv 'timeval) (%gettimeofday tv nil) (with-foreign-slots ((tv-sec tv-usec) tv timeval) (values tv-sec tv-usec)))) --- /project/cells/cvsroot/cells-gtk/cffi/examples/run-examples.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/run-examples.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; run-examples.lisp --- Simple script to run the examples. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; (setf *load-verbose* nil *compile-verbose* nil) #+(and (not asdf) (or sbcl openmcl)) (require "asdf") #+clisp (load "~/Downloads/asdf") (asdf:operate 'asdf:load-op 'cffi-examples :verbose nil) (cffi-examples:run-examples) (force-output) (quit) --- /project/cells/cvsroot/cells-gtk/cffi/examples/translator-test.lisp 2008/01/28 23:59:27 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/examples/translator-test.lisp 2008/01/28 23:59:27 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; translator-test.lisp --- Testing type translators. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; (defpackage #:cffi-translator-test (:use #:common-lisp #:cffi #:cffi-utils)) (in-package #:cffi-translator-test) ;;;# Verbose Pointer Translator ;;; ;;; This is a silly type translator that doesn't actually do any ;;; translating, but it prints out a debug message when the pointer is ;;; converted to/from its foreign representation. (defctype verbose-pointer :pointer) (defmethod translate-to-foreign (value (name (eql 'verbose-pointer))) (format *debug-io* "~&;; to foreign: VERBOSE-POINTER: ~S~%" value) value) (defmethod translate-from-foreign (value (name (eql 'verbose-pointer))) (format *debug-io* "~&;; from foreign: VERBOSE-POINTER: ~S~%" value) value) ;;;# Verbose String Translator ;;; ;;; A VERBOSE-STRING is a typedef for a VERBOSE-POINTER except the ;;; Lisp string is first converted to a C string. If things are ;;; working properly, both type translators should be called when ;;; converting a Lisp string to/from a C string. ;;; ;;; The translators should be called most-specific-first when ;;; translating to C, and most-specific-last when translating from C. (defctype verbose-string verbose-pointer) (defmethod translate-to-foreign ((s string) (name (eql 'verbose-string))) (let ((value (foreign-string-alloc s))) (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~S~%" s value) (values value t))) (defmethod translate-to-foreign (value (name (eql 'verbose-string))) (if (pointerp value) (progn (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~:*~S~%" value) (values value nil)) (error "Cannot convert ~S to a foreign string: it is not a Lisp ~ string or pointer." value))) (defmethod translate-from-foreign (ptr (name (eql 'verbose-string))) (let ((value (foreign-string-to-lisp ptr))) (format *debug-io* "~&;; from foreign: VERBOSE-STRING: ~S -> ~S~%" ptr value) value)) (defmethod free-translated-object (ptr (name (eql 'verbose-string)) free-p) (when free-p (foreign-string-free ptr))) (defun test-verbose-string () (foreign-funcall "getenv" verbose-string "SHELL" verbose-string)) ;;;# Testing Chained Parameters (defctype inner-type :int) (defctype middle-type inner-type) (defctype outer-type middle-type) (defmethod translate-to-foreign (value (name (eql 'inner-type))) (values value 1)) (defmethod translate-to-foreign (value (name (eql 'middle-type))) (values value 2)) (defmethod translate-to-foreign (value (name (eql 'outer-type))) (values value 3)) (defmethod free-translated-object (value (name (eql 'inner-type)) param) (format t "~&;; free inner-type ~A~%" param)) (defmethod free-translated-object (value (name (eql 'middle-type)) param) (format t "~&;; free middle-type ~A~%" param)) (defmethod free-translated-object (value (name (eql 'outer-type)) param) (format t "~&;; free outer-type ~A~%" param)) From ktilton at common-lisp.net Mon Jan 28 23:59:35 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:35 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/scripts Message-ID: <20080128235935.1C3805C192@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/scripts In directory clnet:/tmp/cvs-serv9292/cffi/scripts Added Files: release.sh Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/scripts/release.sh 2008/01/28 23:59:34 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/scripts/release.sh 2008/01/28 23:59:34 1.1 #! /bin/sh # # release.sh --- Create a signed tarball release for ASDF-INSTALL. # # Copyright (C) 2005-2006, James Bielman # # 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. # VERSION=${VERSION:=`date +"%Y%m%d"`} TARBALL_NAME="cffi_$VERSION" TARBALL="$TARBALL_NAME.tar.gz" SIGNATURE="$TARBALL.asc" RELEASE_DIR=${RELEASE_DIR:="/project/cffi/public_html/releases"} echo "Creating distribution..." darcs dist -d "$TARBALL_NAME" echo "Signing tarball..." gpg -b -a "$TARBALL_NAME.tar.gz" echo "Copying tarball to web server..." scp "$TARBALL" "$SIGNATURE" common-lisp.net:"$RELEASE_DIR" echo "Uploaded $TARBALL and $SIGNATURE." echo "Don't forget to update the link on the CLiki page!" From ktilton at common-lisp.net Mon Jan 28 23:59:37 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:37 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/src Message-ID: <20080128235937.A2132601C7@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/src In directory clnet:/tmp/cvs-serv9292/cffi/src Added Files: cffi-allegro.lisp cffi-clisp.lisp cffi-cmucl.lisp cffi-corman.lisp cffi-ecl.lisp cffi-gcl.lisp cffi-lispworks.lisp cffi-openmcl.lisp cffi-sbcl.lisp cffi-scl.lisp early-types.lisp enum.lisp features.lisp foreign-vars.lisp functions.lisp libraries.lisp package.lisp strings.lisp types.lisp utils.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-allegro.lisp 2008/01/28 23:59:35 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-allegro.lisp 2008/01/28 23:59:35 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL. ;;; ;;; Copyright (C) 2005-2006, Luis Oliveira ;;; ;;; 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. ;;; ;;;# Administrivia (defpackage #:cffi-sys (:use #:common-lisp #:cffi-utils) (:export #:canonicalize-symbol-name-case #:pointerp #:pointer-eq #:null-pointer #:null-pointer-p #:inc-pointer #:make-pointer #:pointer-address #:%foreign-alloc #:foreign-free #:with-foreign-pointer #:%foreign-funcall #:%foreign-funcall-pointer #:%foreign-type-alignment #:%foreign-type-size #:%load-foreign-library #:%close-foreign-library #:%mem-ref #:%mem-set ;#:make-shareable-byte-vector ;#:with-pointer-to-vector-data #:foreign-symbol-pointer #:defcfun-helper-forms #:%defcallback #:%callback #:finalize #:cancel-finalization)) (in-package #:cffi-sys) ;;;# Features (eval-when (:compile-toplevel :load-toplevel :execute) (mapc (lambda (feature) (pushnew feature *features*)) '(;; Backend mis-features. cffi-features:no-long-long ;; OS/CPU features. #+macosx cffi-features:darwin #+unix cffi-features:unix #+mswindows cffi-features:windows #+powerpc cffi-features:ppc32 #+x86 cffi-features:x86 #+x86-64 cffi-features:x86-64 ))) ;;; Symbol case. (defun canonicalize-symbol-name-case (name) (declare (string name)) (if (eq excl:*current-case-mode* :case-sensitive-lower) (string-downcase name) (string-upcase name))) ;;;# Basic Pointer Operations (defun pointerp (ptr) "Return true if PTR is a foreign pointer." (integerp ptr)) (defun pointer-eq (ptr1 ptr2) "Return true if PTR1 and PTR2 point to the same address." (eql ptr1 ptr2)) (defun null-pointer () "Return a null pointer." 0) (defun null-pointer-p (ptr) "Return true if PTR is a null pointer." (zerop ptr)) (defun inc-pointer (ptr offset) "Return a pointer pointing OFFSET bytes past PTR." (+ ptr offset)) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." address) (defun pointer-address (ptr) "Return the address pointed to by PTR." ptr) ;;;# Allocation ;;; ;;; Functions and macros for allocating foreign memory on the stack ;;; and on the heap. The main CFFI package defines macros that wrap ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage ;;; when the memory has dynamic extent. (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (ff:allocate-fobject :char :c size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (ff:free-fobject ptr)) (defmacro with-foreign-pointer ((var size &optional size-var) &body body) "Bind VAR to SIZE bytes of foreign memory during BODY. The pointer in VAR is invalid beyond the dynamic extent of BODY, and may be stack-allocated if supported by the implementation. If SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) `(let ((,size-var ,size)) (declare (ignorable ,size-var)) (ff:with-stack-fobject (,var :char :allocation :c :size ,size-var) , at body))) ;;;# Shareable Vectors ;;; ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA ;;; should be defined to perform a copy-in/copy-out if the Lisp ;;; implementation can't do this. ;(defun make-shareable-byte-vector (size) ; "Create a Lisp vector of SIZE bytes can passed to ;WITH-POINTER-TO-VECTOR-DATA." ; (make-array size :element-type '(unsigned-byte 8))) ; ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) ; "Bind PTR-VAR to a foreign pointer to the data in VECTOR." ; `(sb-sys:without-gcing ; (let ((,ptr-var (sb-sys:vector-sap ,vector))) ; , at body))) ;;;# Dereferencing (defun convert-foreign-type (type-keyword &optional (context :normal)) "Convert a CFFI type keyword to an Allegro type." (ecase type-keyword (:char :char) (:unsigned-char :unsigned-char) (:short :short) (:unsigned-short :unsigned-short) (:int :int) (:unsigned-int :unsigned-int) (:long :long) (:unsigned-long :unsigned-long) (:float :float) (:double :double) (:pointer (ecase context (:normal '(* :void)) (:funcall :foreign-address))) (:void :void))) (defun %mem-ref (ptr type &optional (offset 0)) "Dereference an object of TYPE at OFFSET bytes from PTR." (unless (zerop offset) (setf ptr (inc-pointer ptr offset))) (ff:fslot-value-typed (convert-foreign-type type) :c ptr)) ;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the ;;; CFFI type is constant. Allegro does its own transformation on the ;;; call that results in efficient code. (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) (if (constantp type) (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) `(ff:fslot-value-typed ',(convert-foreign-type (eval type)) :c ,ptr-form)) form)) (defun %mem-set (value ptr type &optional (offset 0)) "Set the object of TYPE at OFFSET bytes from PTR." (unless (zerop offset) (setf ptr (inc-pointer ptr offset))) (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value)) ;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED) ;;; when the CFFI type is constant. Allegro does its own ;;; transformation on the call that results in efficient code. (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) (if (constantp type) (once-only (val) (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type)) :c ,ptr-form) ,val))) form)) ;;;# Calling Foreign Functions (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (ff:sizeof-fobject (convert-foreign-type type-keyword))) (defun %foreign-type-alignment (type-keyword) "Returns the alignment in bytes of a foreign type." #+(and powerpc macosx32) (when (eq type-keyword :double) (return-from %foreign-type-alignment 8)) ;; No override necessary for the remaining types.... (ff::sized-ftype-prim-align (ff::iforeign-type-sftype (ff:get-foreign-type (convert-foreign-type type-keyword))))) (defun foreign-funcall-type-and-args (args) "Returns a list of types, list of args and return type." (let ((return-type :void)) (loop for (type arg) on args by #'cddr if arg collect (convert-foreign-type type :funcall) into types and collect arg into fargs else do (setf return-type (convert-foreign-type type :funcall)) finally (return (values types fargs return-type))))) (defun convert-to-lisp-type (type) (if (equal '(* :void) type) 'integer (ecase type (:char 'signed-byte) (:unsigned-char 'integer) ;'unsigned-byte) ((:short :unsigned-short :int :unsigned-int :long :unsigned-long) 'integer) (:float 'single-float) (:double 'double-float) (:foreign-address :foreign-address) (:void 'null)))) (defun foreign-allegro-type (type) (if (eq type :foreign-address) nil type)) (defun allegro-type-pair (type) (list (foreign-allegro-type type) (convert-to-lisp-type type))) #+ignore (defun note-named-foreign-function (symbol name types rettype) "Give Allegro's compiler a hint to perform a direct call." `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',symbol 'system::direct-ff-call) (list '(,name :language :c) t ; callback :c ; convention ;; return type '(:c-type lisp-type) ',(allegro-type-pair (convert-foreign-type rettype :funcall)) ;; arg types '({(:c-type lisp-type)}*) '(,@(loop for type in types collect (allegro-type-pair (convert-foreign-type type :funcall)))) nil ; arg-checking ff::ep-flag-never-release)))) (defmacro %foreign-funcall (name &rest args) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(system::ff-funcall (load-time-value (excl::determine-foreign-address '(,name :language :c) ff::ep-flag-never-release nil ; method-index )) ;; arg types {'(:c-type lisp-type) argN}* ,@(mapcan (lambda (type arg) `(',(allegro-type-pair type) ,arg)) types fargs) ;; return type '(:c-type lisp-type) ',(allegro-type-pair rettype)))) (defun defcfun-helper-forms (name lisp-name rettype args types) "Return 2 values for DEFCFUN. A prelude form and a caller form." (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))) (values `(ff:def-foreign-call (,ff-name ,name) ,(mapcar (lambda (ty) (let ((allegro-type (convert-foreign-type ty))) (list (gensym) allegro-type (convert-to-lisp-type allegro-type)))) types) :returning ,(allegro-type-pair (convert-foreign-type rettype :funcall)) ;; Don't use call-direct when there are no arguments. ,@(unless (null args) '(:call-direct t)) :arg-checking nil :strings-convert nil) `(,ff-name , at args)))) ;;; See doc/allegro-internals.txt for a clue about entry-vec. (defmacro %foreign-funcall-pointer (ptr &rest args) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) (with-unique-names (entry-vec) `(let ((,entry-vec (excl::make-entry-vec-boa))) (setf (aref ,entry-vec 1) ,ptr) ; set jump address (system::ff-funcall ,entry-vec ;; arg types {'(:c-type lisp-type) argN}* ,@(mapcan (lambda (type arg) `(',(allegro-type-pair type) ,arg)) types fargs) ;; return type '(:c-type lisp-type) ',(allegro-type-pair rettype)))))) ;;;# Callbacks ;;; The *CALLBACKS* hash table contains information about a callback ;;; for the Allegro FFI. The key is the name of the CFFI callback, ;;; and the value is a cons, the car containing the symbol the ;;; callback was defined on in the CFFI-CALLBACKS package, the cdr ;;; being an Allegro FFI pointer (a fixnum) that can be passed to C ;;; functions. ;;; ;;; These pointers must be restored when a saved Lisp image is loaded. ;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to ;;; re-register the callbacks during Lisp startup. (defvar *callbacks* (make-hash-table)) ;;; Register a callback in the *CALLBACKS* hash table. (defun register-callback (cffi-name callback-name) (setf (gethash cffi-name *callbacks*) (cons callback-name (ff:register-foreign-callable callback-name :reuse t)))) ;;; Restore the saved pointers in *CALLBACKS* when loading an image. (defun restore-callbacks () (maphash (lambda (key value) (register-callback key (car value))) *callbacks*)) ;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing ;;; CFFI is restarted. (eval-when (:load-toplevel :execute) (pushnew 'restore-callbacks excl:*restart-actions*)) ;;; Create a package to contain the symbols for callback functions. (defpackage #:cffi-callbacks (:use)) (defun intern-callback (name) (intern (format nil "~A::~A" (package-name (symbol-package name)) (symbol-name name)) '#:cffi-callbacks)) (defmacro %defcallback (name rettype arg-names arg-types &body body) (declare (ignore rettype)) (let ((cb-name (intern-callback name))) `(progn (ff:defun-foreign-callable ,cb-name ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) arg-names arg-types) (declare (:convention :c)) , at body) (register-callback ',name ',cb-name)))) ;;; Return the saved Lisp callback pointer from *CALLBACKS* for the ;;; CFFI callback named NAME. (defun %callback (name) (or (cdr (gethash name *callbacks*)) (error "Undefined callback: ~S" name))) ;;;# Loading and Closing Foreign Libraries (defun %load-foreign-library (name) "Load the foreign library NAME." ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load ;; the argument. However, previous versions do not and will only ;; foreign load the argument if its type is a member of the ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special ;; to a list containing whatever type NAME has. (let ((excl::*load-foreign-types* (list (pathname-type (parse-namestring name))))) (ignore-errors #+(version>= 7) (load name :foreign t) [40 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-clisp.lisp 2008/01/28 23:59:36 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-clisp.lisp 2008/01/28 23:59:36 1.1 [398 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-cmucl.lisp 2008/01/28 23:59:36 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-cmucl.lisp 2008/01/28 23:59:36 1.1 [763 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-corman.lisp 2008/01/28 23:59:36 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-corman.lisp 2008/01/28 23:59:36 1.1 [1123 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-ecl.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-ecl.lisp 2008/01/28 23:59:37 1.1 [1411 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-gcl.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-gcl.lisp 2008/01/28 23:59:37 1.1 [1724 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-lispworks.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-lispworks.lisp 2008/01/28 23:59:37 1.1 [2141 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-openmcl.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-openmcl.lisp 2008/01/28 23:59:37 1.1 [2470 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-sbcl.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-sbcl.lisp 2008/01/28 23:59:37 1.1 [2803 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/cffi-scl.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/cffi-scl.lisp 2008/01/28 23:59:37 1.1 [3152 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/early-types.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/early-types.lisp 2008/01/28 23:59:37 1.1 [3694 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/enum.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/enum.lisp 2008/01/28 23:59:37 1.1 [3898 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/features.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/features.lisp 2008/01/28 23:59:37 1.1 [3955 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/foreign-vars.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/foreign-vars.lisp 2008/01/28 23:59:37 1.1 [4039 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/functions.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/functions.lisp 2008/01/28 23:59:37 1.1 [4248 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/libraries.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/libraries.lisp 2008/01/28 23:59:37 1.1 [4503 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/package.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/package.lisp 2008/01/28 23:59:37 1.1 [4620 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/strings.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/strings.lisp 2008/01/28 23:59:37 1.1 [4760 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/types.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/types.lisp 2008/01/28 23:59:37 1.1 [5446 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/src/utils.lisp 2008/01/28 23:59:37 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/src/utils.lisp 2008/01/28 23:59:37 1.1 [5632 lines skipped] From ktilton at common-lisp.net Mon Jan 28 23:59:38 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:38 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/tests Message-ID: <20080128235938.0DBD863036@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/tests In directory clnet:/tmp/cvs-serv9292/cffi/tests Added Files: Makefile bindings.lisp callbacks.lisp compile.bat defcfun.lisp enum.lisp foreign-globals.lisp funcall.lisp libtest.c memory.lisp misc-types.lisp misc.lisp package.lisp random-tester.lisp run-tests.lisp struct.lisp union.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/tests/Makefile 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/Makefile 2008/01/28 23:59:38 1.1 # -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- # # Makefile --- Make targets for various tasks. # # Copyright (C) 2005, James Bielman # # 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. # OSTYPE = $(shell uname) CC := gcc CFLAGS := -lm -Wall -std=c99 -pedantic SHLIB_CFLAGS := -shared SHLIB_EXT := .so ifneq ($(if $(findstring $(OSTYPE),Linux FreeBSD),OK), OK) ifeq ($(OSTYPE), Darwin) SHLIB_CFLAGS := -bundle else ifeq ($(OSTYPE), SunOS) CFLAGS := -c -Wall -std=c99 -pedantic else # Let's assume this is win32 SHLIB_EXT := .dll endif endif endif ARCH = $(shell uname -m) ifeq ($(ARCH), x86_64) CFLAGS += -fPIC endif # Are all G5s ppc970s? ifeq ($(ARCH), ppc970) CFLAGS += -m64 endif SHLIBS = libtest$(SHLIB_EXT) ifeq ($(ARCH), x86_64) SHLIBS += libtest32$(SHLIB_EXT) endif shlibs: $(SHLIBS) libtest$(SHLIB_EXT): libtest.c $(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $< ifeq ($(ARCH), x86_64) libtest32$(SHLIB_EXT): libtest.c $(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $< endif clean: rm -f *.so *.dylib *.dll *.bundle # vim: ft=make ts=3 noet --- /project/cells/cvsroot/cells-gtk/cffi/tests/bindings.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/bindings.lisp 2008/01/28 23:59:38 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; libtest.lisp --- Setup CFFI bindings for libtest. ;;; ;;; Copyright (C) 2005-2006, Luis Oliveira ;;; ;;; 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. ;;; (in-package #:cffi-tests) (define-foreign-library libtest (:unix (:or "libtest.so" "libtest32.so")) (:darwin "libtest.so") (:windows "libtest.dll" "msvcrt.dll")) ;;; Return the directory containing the source when compiling or ;;; loading this file. We don't use *LOAD-TRUENAME* because the fasl ;;; file may be in a different directory than the source with certain ;;; ASDF extensions loaded. (defun load-directory () (let ((here #.(or *compile-file-truename* *load-truename*))) (make-pathname :directory (pathname-directory here)))) #-(:and :ecl (:not :dffi)) (let ((*foreign-library-directories* (list (load-directory)))) (load-foreign-library 'libtest)) #+(:and :ecl (:not :dffi)) (ffi:load-foreign-library #.(make-pathname :name "libtest" :type "o" :defaults (or *compile-file-truename* *load-truename*))) ;;; check libtest version (defparameter *required-dll-version* "20060414") (defcvar "dll_version" :string) (unless (string= *dll-version* *required-dll-version*) (error "version check failed: expected ~s but libtest reports ~s" *required-dll-version* *dll-version*)) ;;; The maximum and minimum values for single and double precision C ;;; floating point values, which may be quite different from the ;;; corresponding Lisp versions. (defcvar "float_max" :float) (defcvar "float_min" :float) (defcvar "double_max" :double) (defcvar "double_min" :double) ;;; This is not the best place for this code... (defparameter *repeat* 1) (defun run-cffi-tests (&key (compiled nil)) (let ((rt::*compile-tests* compiled) (*package* (find-package '#:cffi-tests))) (format t "~2&How many times shall we run the tests (~Acompiled)? [~D]: " (if compiled "" "un") *repeat*) (force-output *standard-output*) (let* ((ntimes (or (ignore-errors (parse-integer (read-line))) *repeat*)) (ret-values (loop repeat ntimes collect (do-tests)))) (format t "~&;;; Finished running tests (~Acompiled) ~D times." (if compiled "" "un") ntimes) (every #'identity ret-values))))--- /project/cells/cvsroot/cells-gtk/cffi/tests/callbacks.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/callbacks.lisp 2008/01/28 23:59:38 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; callbacks.lisp --- Tests on callbacks. ;;; ;;; Copyright (C) 2005-2006, Luis Oliveira ;;; ;;; 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. ;;; (in-package #:cffi-tests) (defcfun "expect_char_sum" :int (f :pointer)) (defcfun "expect_unsigned_char_sum" :int (f :pointer)) (defcfun "expect_short_sum" :int (f :pointer)) (defcfun "expect_unsigned_short_sum" :int (f :pointer)) (defcfun "expect_int_sum" :int (f :pointer)) (defcfun "expect_unsigned_int_sum" :int (f :pointer)) (defcfun "expect_long_sum" :int (f :pointer)) (defcfun "expect_unsigned_long_sum" :int (f :pointer)) (defcfun "expect_float_sum" :int (f :pointer)) (defcfun "expect_double_sum" :int (f :pointer)) (defcfun "expect_pointer_sum" :int (f :pointer)) (defcfun "expect_strcat" :int (f :pointer)) #-cffi-features:no-long-long (progn (defcfun "expect_long_long_sum" :int (f :pointer)) (defcfun "expect_unsigned_long_long_sum" :int (f :pointer))) #+(and scl long-float) (defcfun "expect_long_double_sum" :int (f :pointer)) (defcallback sum-char :char ((a :char) (b :char)) "Test if the named block is present and the docstring too." ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (return-from sum-char (+ a b))) (defcallback sum-unsigned-char :unsigned-char ((a :unsigned-char) (b :unsigned-char)) ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (+ a b)) (defcallback sum-short :short ((a :short) (b :short)) ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (+ a b)) (defcallback sum-unsigned-short :unsigned-short ((a :unsigned-short) (b :unsigned-short)) ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (+ a b)) (defcallback sum-int :int ((a :int) (b :int)) (+ a b)) (defcallback sum-unsigned-int :unsigned-int ((a :unsigned-int) (b :unsigned-int)) (+ a b)) (defcallback sum-long :long ((a :long) (b :long)) (+ a b)) (defcallback sum-unsigned-long :unsigned-long ((a :unsigned-long) (b :unsigned-long)) (+ a b)) #-cffi-features:no-long-long (progn (defcallback sum-long-long :long-long ((a :long-long) (b :long-long)) (+ a b)) (defcallback sum-unsigned-long-long :unsigned-long-long ((a :unsigned-long-long) (b :unsigned-long-long)) (+ a b))) (defcallback sum-float :float ((a :float) (b :float)) ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (+ a b)) (defcallback sum-double :double ((a :double) (b :double)) ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (+ a b)) #+(and scl long-float) (defcallback sum-long-double :long-double ((a :long-double) (b :long-double)) ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) (+ a b)) (defcallback sum-pointer :pointer ((ptr :pointer) (offset :int)) (inc-pointer ptr offset)) (defcallback lisp-strcat :string ((a :string) (b :string)) (concatenate 'string a b)) (deftest callbacks.char (expect-char-sum (get-callback 'sum-char)) 1) (deftest callbacks.unsigned-char (expect-unsigned-char-sum (get-callback 'sum-unsigned-char)) 1) (deftest callbacks.short (expect-short-sum (callback sum-short)) 1) (deftest callbacks.unsigned-short (expect-unsigned-short-sum (callback sum-unsigned-short)) 1) (deftest callbacks.int (expect-int-sum (callback sum-int)) 1) (deftest callbacks.unsigned-int (expect-unsigned-int-sum (callback sum-unsigned-int)) 1) (deftest callbacks.long (expect-long-sum (callback sum-long)) 1) (deftest callbacks.unsigned-long (expect-unsigned-long-sum (callback sum-unsigned-long)) 1) #-cffi-features:no-long-long (progn #+openmcl (push 'callbacks.long-long rt::*expected-failures*) (deftest callbacks.long-long (expect-long-long-sum (callback sum-long-long)) 1) (deftest callbacks.unsigned-long-long (expect-unsigned-long-long-sum (callback sum-unsigned-long-long)) 1)) (deftest callbacks.float (expect-float-sum (callback sum-float)) 1) (deftest callbacks.double (expect-double-sum (callback sum-double)) 1) #+(and scl long-float) (deftest callbacks.long-double (expect-long-double-sum (callback sum-long-double)) 1) (deftest callbacks.pointer (expect-pointer-sum (callback sum-pointer)) 1) (deftest callbacks.string (expect-strcat (callback lisp-strcat)) 1) #-cffi-features:no-foreign-funcall (defcallback return-a-string-not-nil :string () "abc") #-cffi-features:no-foreign-funcall (deftest callbacks.string-not-docstring (foreign-funcall (callback return-a-string-not-nil) :string) "abc") ;;; This one tests mem-aref too. (defcfun "qsort" :void (base :pointer) (nmemb :int) (size :int) (fun-compar :pointer)) (defcallback < :int ((a :pointer) (b :pointer)) (let ((x (mem-ref a :int)) (y (mem-ref b :int))) (cond ((> x y) 1) ((< x y) -1) (t 0)))) (deftest callbacks.qsort (with-foreign-object (array :int 10) ;; Initialize array. (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8) do (setf (mem-aref array :int i) n)) ;; Sort it. (qsort array 10 (foreign-type-size :int) (callback <)) ;; Return it as a list. (loop for i from 0 below 10 collect (mem-aref array :int i))) (1 2 3 4 5 6 7 8 9 10)) ;;; void callback (defparameter *int* -1) (defcfun "pass_int_ref" :void (f :pointer)) ;;; CMUCL chokes on this one for some reason. #-(and cffi-features:darwin cmu) (defcallback read-int-from-pointer :void ((a :pointer)) (setq *int* (mem-ref a :int))) #+(and cffi-features:darwin cmu) (pushnew 'callbacks.void rt::*expected-failures*) (deftest callbacks.void (progn (pass-int-ref (callback read-int-from-pointer)) *int*) 1984) ;;; test funcalling of a callback and also declarations inside ;;; callbacks. #-cffi-features:no-foreign-funcall (progn (defcallback sum-2 :int ((a :int) (b :int) (c :int)) (declare (ignore c)) (+ a b)) [254 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/compile.bat 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/compile.bat 2008/01/28 23:59:38 1.1 [260 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/defcfun.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/defcfun.lisp 2008/01/28 23:59:38 1.1 [621 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/enum.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/enum.lisp 2008/01/28 23:59:38 1.1 [736 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/foreign-globals.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/foreign-globals.lisp 2008/01/28 23:59:38 1.1 [973 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/funcall.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/funcall.lisp 2008/01/28 23:59:38 1.1 [1146 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/libtest.c 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/libtest.c 2008/01/28 23:59:38 1.1 [1925 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/memory.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/memory.lisp 2008/01/28 23:59:38 1.1 [2461 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/misc-types.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/misc-types.lisp 2008/01/28 23:59:38 1.1 [2694 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/misc.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/misc.lisp 2008/01/28 23:59:38 1.1 [2783 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/package.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/package.lisp 2008/01/28 23:59:38 1.1 [2815 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/random-tester.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/random-tester.lisp 2008/01/28 23:59:38 1.1 [3061 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/run-tests.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/run-tests.lisp 2008/01/28 23:59:38 1.1 [3106 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/struct.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/struct.lisp 2008/01/28 23:59:38 1.1 [3402 lines skipped] --- /project/cells/cvsroot/cells-gtk/cffi/tests/union.lisp 2008/01/28 23:59:38 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/tests/union.lisp 2008/01/28 23:59:38 1.1 [3452 lines skipped] From ktilton at common-lisp.net Mon Jan 28 23:59:41 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:41 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/cffi/uffi-compat Message-ID: <20080128235941.8E7CF73239@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/cffi/uffi-compat In directory clnet:/tmp/cvs-serv9292/cffi/uffi-compat Added Files: uffi-compat.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/cffi/uffi-compat/uffi-compat.lisp 2008/01/28 23:59:41 NONE +++ /project/cells/cvsroot/cells-gtk/cffi/uffi-compat/uffi-compat.lisp 2008/01/28 23:59:41 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; ;;; 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. ;;; ;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg. (defpackage #:cffi-uffi-compat (:nicknames #:uffi) ;; is this a good idea? (:use #:cl) (:export ;; immediate types #:def-constant #:def-foreign-type #:def-type #:null-char-p ;; aggregate types #:def-enum #:def-struct #:get-slot-value #:get-slot-pointer #:def-array-pointer #:deref-array #:def-union ;; objects #:allocate-foreign-object #:free-foreign-object #:with-foreign-object #:with-foreign-objects #:size-of-foreign-type #:pointer-address #:deref-pointer #:ensure-char-character #:ensure-char-integer #:ensure-char-storable #:null-pointer-p #:make-null-pointer #:make-pointer #:+null-cstring-pointer+ #:char-array-to-pointer #:with-cast-pointer #:def-foreign-var #:convert-from-foreign-usb8 ;; string functions #:convert-from-cstring #:convert-to-cstring #:free-cstring #:with-cstring #:with-cstrings #:convert-from-foreign-string #:convert-to-foreign-string #:allocate-foreign-string #:with-foreign-string #:with-foreign-strings #:foreign-string-length ; not implemented ;; function call #:def-function ;; libraries #:find-foreign-library #:load-foreign-library #:default-foreign-library-type #:foreign-library-types ;; os #:getenv #:run-shell-command )) (in-package #:cffi-uffi-compat) #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) (when (equal (machine-type) "POWER MACINTOSH") (pushnew :ppc *features*))) (defun convert-uffi-type (uffi-type) "Convert a UFFI primitive type to a CFFI type." ;; Many CFFI types are the same as UFFI. This list handles the ;; exceptions only. (case uffi-type (:cstring :pointer) (:pointer-void :pointer) (:pointer-self :pointer) (:char '(uffi-char :char)) (:unsigned-char '(uffi-char :unsigned-char)) (:byte :char) (:unsigned-byte :unsigned-char) (t (if (listp uffi-type) (case (car uffi-type) ;; this is imho gross but it is what uffi does (quote (convert-uffi-type (second uffi-type))) (* :pointer) (:array `(uffi-array ,(convert-uffi-type (second uffi-type)) ,(third uffi-type))) (:union (second uffi-type)) (:struct (convert-uffi-type (second uffi-type))) (:struct-pointer :pointer)) uffi-type)))) (defclass uffi-array-type (cffi::foreign-typedef) ;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref. ((element-type :initform (error "An element-type is required.") :accessor element-type :initarg :element-type) (nelems :initform (error "nelems is required.") :accessor nelems :initarg :nelems)) (:documentation "UFFI's :array type.")) (defmethod initialize-instance :after ((self uffi-array-type) &key) (setf (cffi::actual-type self) (cffi::parse-type :pointer))) (defmethod cffi:foreign-type-size ((type uffi-array-type)) (* (cffi:foreign-type-size (element-type type)) (nelems type))) (defmethod cffi::aggregatep ((type uffi-array-type)) t) (cffi::define-type-spec-parser uffi-array (element-type count) (make-instance 'uffi-array-type :element-type element-type :nelems (or count 1))) ;; UFFI's :(unsigned-)char (cffi:define-foreign-type uffi-char (base-type) base-type) (defmethod cffi:translate-to-foreign ((value character) (name (eql 'uffi-char))) (char-code value)) (defmethod cffi:translate-from-foreign (obj (name (eql 'uffi-char))) (code-char obj)) (defmethod cffi::unparse ((name (eql 'uffi-char)) type) `(uffi-char ,(cffi::name (cffi::actual-type type)))) (defmacro def-type (name type) "Define a Common Lisp type NAME for UFFI type TYPE." (declare (ignore type)) `(deftype ,name () t)) (defmacro def-foreign-type (name type) "Define a new foreign type." `(cffi:defctype ,name ,(convert-uffi-type type))) (defmacro def-constant (name value &key export) "Define a constant and conditionally export it." `(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant ,name ,value) ,@(when export `((export ',name))) ',name)) (defmacro null-char-p (val) "Return true if character is null." `(zerop (char-code ,val))) (defmacro def-enum (enum-name args &key (separator-string "#")) "Creates a constants for a C type enum list, symbols are created in the created in the current package. The symbol is the concatenation of the enum-name name, separator-string, and field-name" (let ((counter 0) (cmds nil) (constants nil)) (declare (fixnum counter)) (dolist (arg args) (let ((name (if (listp arg) (car arg) arg)) (value (if (listp arg) (prog1 (setq counter (cadr arg)) (incf counter)) (prog1 counter (incf counter))))) (setq name (intern (concatenate 'string (symbol-name enum-name) separator-string (symbol-name name)))) (push `(def-constant ,name ,value) constants))) (setf cmds (append '(progn) `((cffi:defctype ,enum-name :int)) (nreverse constants))) cmds)) (defmacro def-struct (name &body fields) "Define a C structure." `(cffi:defcstruct ,name ,@(loop for (name uffi-type) in fields for cffi-type = (convert-uffi-type uffi-type) collect (list name cffi-type)))) ;; TODO: figure out why the compiler macro is kicking in before ;; the setf expander. (defun %foreign-slot-value (obj type field) (cffi:foreign-slot-value obj type field)) (defun (setf %foreign-slot-value) (value obj type field) (setf (cffi:foreign-slot-value obj type field) value)) (defmacro get-slot-value (obj type field) "Access a slot value from a structure." `(%foreign-slot-value ,obj ,type ,field)) ;; UFFI uses a different function when accessing a slot whose ;; type is a pointer. We don't need that in CFFI so we use ;; foreign-slot-value too. (defmacro get-slot-pointer (obj type field) "Access a pointer slot value from a structure." `(cffi:foreign-slot-value ,obj ,type ,field)) (defmacro def-array-pointer (name type) "Define a foreign array type." `(cffi:defctype ,name (uffi-array ,(convert-uffi-type type) 1))) (defmacro deref-array (array type position) "Dereference an array." `(cffi:mem-aref ,array ,(if (constantp type) `',(element-type (cffi::parse-type (convert-uffi-type (eval type)))) `(element-type (cffi::parse-type (convert-uffi-type ,type)))) ,position)) ;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure ;; if DEFCUNION and DEF-UNION are strictly compatible. (defmacro def-union (name &body fields) "Define a foreign union type." `(cffi:defcunion ,name ,@(loop for (name uffi-type) in fields for cffi-type = (convert-uffi-type uffi-type) collect (list name cffi-type)))) (defmacro allocate-foreign-object (type &optional (size 1)) "Allocate one or more instance of a foreign type." `(cffi:foreign-alloc ,(if (constantp type) `',(convert-uffi-type (eval type)) `(convert-uffi-type ,type)) :count ,size)) (defmacro free-foreign-object (ptr) "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT." `(cffi:foreign-free ,ptr)) (defmacro with-foreign-object ((var type) &body body) "Wrap the allocation of a foreign object around BODY." `(cffi:with-foreign-object (,var (convert-uffi-type ,type)) , at body)) ;; Taken from UFFI's src/objects.lisp (defmacro with-foreign-objects (bindings &rest body) (if bindings `(with-foreign-object ,(car bindings) (with-foreign-objects ,(cdr bindings) , at body)) `(progn , at body))) (defmacro size-of-foreign-type (type) "Return the size in bytes of a foreign type." `(cffi:foreign-type-size (convert-uffi-type ,type))) (defmacro pointer-address (ptr) "Return the address of a pointer." `(cffi:pointer-address ,ptr)) ;; Hmm, we need to translate chars, so translations are necessary here. (defun %deref-pointer (ptr type) (cffi::translate-type-from-foreign (cffi:mem-ref ptr type) (cffi::parse-type type))) (defun (setf %deref-pointer) (value ptr type) (setf (cffi:mem-ref ptr type) (cffi::translate-type-to-foreign value (cffi::parse-type type)))) (defmacro deref-pointer (ptr type) "Dereference a pointer." `(%deref-pointer ,ptr (convert-uffi-type ,type))) (defmacro ensure-char-character (obj &environment env) "Convert OBJ to a character if it is an integer." (if (constantp obj env) (if (characterp obj) obj (code-char obj)) (let ((obj-var (gensym))) `(let ((,obj-var ,obj)) (if (characterp ,obj-var) ,obj-var (code-char ,obj-var)))))) (defmacro ensure-char-integer (obj &environment env) "Convert OBJ to an integer if it is a character." (if (constantp obj env) (let ((the-obj (eval obj))) (if (characterp the-obj) (char-code the-obj) the-obj)) (let ((obj-var (gensym))) `(let ((,obj-var ,obj)) (if (characterp ,obj-var) (char-code ,obj-var) ,obj-var))))) (defmacro ensure-char-storable (obj) "Ensure OBJ is storable as a character." `(ensure-char-integer ,obj)) (defmacro make-null-pointer (type) "Create a NULL pointer." (declare (ignore type)) `(cffi:null-pointer)) (defmacro make-pointer (address type) "Create a pointer to ADDRESS." (declare (ignore type)) `(cffi:make-pointer ,address)) (defmacro null-pointer-p (ptr) "Return true if PTR is a null pointer." `(cffi:null-pointer-p ,ptr)) (defparameter +null-cstring-pointer+ (cffi:null-pointer) "A constant NULL string pointer.") (defmacro char-array-to-pointer (obj) obj) (defmacro with-cast-pointer ((var ptr type) &body body) "Cast a pointer, does nothing in CFFI." (declare (ignore type)) `(let ((,var ,ptr)) , at body)) (defmacro def-foreign-var (name type module) "Define a symbol macro to access a foreign variable." (declare (ignore module)) (flet ((lisp-name (name) (intern (cffi-sys:canonicalize-symbol-name-case (substitute #\- #\_ name))))) `(cffi:defcvar ,(if (listp name) name (list name (lisp-name name))) ,(convert-uffi-type type)))) (defmacro convert-from-cstring (s) "Convert a cstring to a Lisp string." (let ((ret (gensym))) `(let ((,ret (cffi:foreign-string-to-lisp ,s))) (if (equal ,ret "") nil ,ret)))) (defmacro convert-to-cstring (obj) "Convert a Lisp string to a cstring." (let ((str (gensym))) `(let ((,str ,obj)) (if (null ,str) (cffi:null-pointer) (cffi:foreign-string-alloc ,str))))) (defmacro free-cstring (ptr) "Free a cstring." `(cffi:foreign-string-free ,ptr)) (defmacro with-cstring ((foreign-string lisp-string) &body body) "Binds a newly creating string." (let ((str (gensym))) `(let ((,str ,lisp-string)) (if (null ,str) (let ((,foreign-string (cffi:null-pointer))) , at body) (cffi:with-foreign-string (,foreign-string ,str) , at body))))) ;; Taken from UFFI's src/strings.lisp (defmacro with-cstrings (bindings &rest body) (if bindings `(with-cstring ,(car bindings) (with-cstrings ,(cdr bindings) , at body)) [224 lines skipped] From ktilton at common-lisp.net Mon Jan 28 23:59:49 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:49 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/gtk-ffi Message-ID: <20080128235949.D22F049111@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/gtk-ffi In directory clnet:/tmp/cvs-serv9292/gtk-ffi Added Files: Makefile Makefile.test Makefile.win32 cellsgtk.def gdk-other.lisp gdk.h gdkalias.h gdkinternals.h gdkintl.h gdkkeysyms.h gtk-adds-hold.c gtk-adds.c gtk-adds.def gtk-button.lisp gtk-core.lisp gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-list-tree.lisp gtk-menu.lisp gtk-other.lisp gtk-tool.lisp gtk-utilities.lisp hello-gtk-adds.c libcellsgtk.dll package.lisp specs.new Log Message: --- /project/cells/cvsroot/cells-gtk/gtk-ffi/Makefile 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/Makefile 2008/01/28 23:59:42 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.so FOR LINUX AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.so # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # In order to compile the library you will need to have on hand the C header files # corresponding the libgtk.so you are using. # See http://developer.gnome.org/doc/API/2.4/gtk/gtk-building.html # On linux, it is a matter of installing 4 or 5 .rpms and typing "make" # Or at least that is how it worked for me. # # Once built, place the library in the directory containing libgtk. all: gcc -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` gcc -shared -o libcellsgtk.so gtk-adds.o `pkg-config --cflags --libs gtk+-2.0`--- /project/cells/cvsroot/cells-gtk/gtk-ffi/Makefile.test 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/Makefile.test 2008/01/28 23:59:42 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.dll FOR WIN32 AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.dll # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # I build libcellsgtk.dll under cygwin. I use the win32 development directories from the site # ftp://ftp.gtk.org/pub/gtk/v2.8/win32 and also ftp://ftp.gtk.org/pub/gtk/v2.8/dependencies # I tried also the gtk-devel stuff you can get directly # with cygwin setup.exe, but it doesn't seem to have everything you need. When you get it all # downloaded, modify the '.pc' files in /local/win32/gtk/lib/pkgconfig so that prefix= # is set to wherever you placed the stuff. # Here is a list of the pc files.... # # -rwx------ 1 pdenno users 267 2005-11-13 15:02 atk.pc # -rwx------ 1 pdenno users 267 2005-11-13 15:02 cairo.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-2.0.pc # -rwx------ 1 pdenno users 287 2005-11-13 15:03 gdk-pixbuf-2.0.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-win32-2.0.pc # -rwx------ 1 pdenno users 355 2005-11-13 15:03 glib-2.0.pc # -rwx------ 1 pdenno users 260 2005-11-13 15:04 gmodule-2.0.pc # -rwx------ 1 pdenno users 259 2005-11-13 15:04 gmodule-no-export-2.0.pc # -rwx------ 1 pdenno users 251 2005-11-13 15:04 gobject-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:05 gthread-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-win32-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:07 libpng.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng12.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng13.pc # -rwx------ 1 pdenno users 322 2005-11-13 15:07 pango.pc # -rwx------ 1 pdenno users 315 2005-11-13 15:07 pangocairo.pc # -rwx------ 1 pdenno users 403 2005-11-13 15:08 pangoft2.pc # -rwx------ 1 pdenno users 276 2005-11-13 15:08 pangowin32.pc # # ...and where is what the first line of one looks like on my machine: # prefix=/local/win32/gtk # Some like libpng have prefix=/usr ... because that is where it is. # # Once built, place the library in the directory containing libgtk. all: gcc -mno-cygwin -c hello-gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` gcc -mno-cygwin -mwindows -L/usr/lib/mingw -o hello-gtk-adds hello-gtk-adds.o -lcellsgtk `pkg-config --cflags --libs gtk+-2.0` -specs=specs.new --- /project/cells/cvsroot/cells-gtk/gtk-ffi/Makefile.win32 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/Makefile.win32 2008/01/28 23:59:42 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.dll FOR WIN32 AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.dll # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # I build libcellsgtk.dll under cygwin. I use the win32 development directories from the site # ftp://ftp.gtk.org/pub/gtk/v2.8/win32 and also ftp://ftp.gtk.org/pub/gtk/v2.8/dependencies # I tried also the gtk-devel stuff you can get directly # with cygwin setup.exe, but it doesn't seem to have everything you need. When you get it all # downloaded, modify the '.pc' files in /local/win32/gtk/lib/pkgconfig so that prefix= # is set to wherever you placed the stuff. # Here is a list of the pc (package config) files.... # # -rwx------ 1 pdenno users 267 2005-11-13 15:02 atk.pc # -rwx------ 1 pdenno users 267 2005-11-13 15:02 cairo.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-2.0.pc # -rwx------ 1 pdenno users 287 2005-11-13 15:03 gdk-pixbuf-2.0.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-win32-2.0.pc # -rwx------ 1 pdenno users 355 2005-11-13 15:03 glib-2.0.pc # -rwx------ 1 pdenno users 260 2005-11-13 15:04 gmodule-2.0.pc # -rwx------ 1 pdenno users 259 2005-11-13 15:04 gmodule-no-export-2.0.pc # -rwx------ 1 pdenno users 251 2005-11-13 15:04 gobject-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:05 gthread-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-win32-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:07 libpng.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng12.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng13.pc # -rwx------ 1 pdenno users 322 2005-11-13 15:07 pango.pc # -rwx------ 1 pdenno users 315 2005-11-13 15:07 pangocairo.pc # -rwx------ 1 pdenno users 403 2005-11-13 15:08 pangoft2.pc # -rwx------ 1 pdenno users 276 2005-11-13 15:08 pangowin32.pc # # ...and where is what the first line of one looks like on my machine: # prefix=/local/win32/gtk # Some like libpng have prefix=/usr ... because that is where it is (cygwin default). # # Once built, place the library in the directory containing libgtk. all: gcc -mno-cygwin -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` dlltool -e exports.o -z cellsgtk.def -l cellsgtk.lib gtk-adds.o gcc -mno-cygwin -mwindows -mdll -L/usr/lib/mingw gtk-adds.o exports.o -o libcellsgtk.dll `pkg-config --cflags --libs gtk+-2.0` -specs=specs.new --- /project/cells/cvsroot/cells-gtk/gtk-ffi/cellsgtk.def 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/cellsgtk.def 2008/01/28 23:59:42 1.1 ; dlltool -e exports.o -z cellsgtk.def -l cellsgtk.lib gtk-adds.o EXPORTS gtk_adds_widget_window @ 1 gtk_adds_color_set_rgb @ 2 gtk_adds_dialog_vbox @ 3 gtk_adds_ok @ 4 gtk_adds_text_iter_new @ 5 gtk_adds_text_view_popup_menu @ 6 gtk_adds_tree_iter_new @ 7 gtk_adds_widget_mapped_p @ 8 gtk_adds_widget_visible_p @ 9 gtk_adds_color_new @ 10 --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gdk-other.lisp 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gdk-other.lisp 2008/01/28 23:59:42 1.1 (in-package :gtk-ffi) (def-gtk-lib-functions :gdk (gdk-gc-new ((drawable c-pointer)) c-pointer) (gdk-draw-line ((drawable c-pointer) (gc c-pointer) (x1 int) (y1 int) (x2 int) (y2 int))) (gdk-pixmap-new ((drawable c-pointer) (width int) (height int) (depth int)) c-pointer) (gdk-draw-drawable ((drawable c-pointer) (gc c-pointer) (src c-pointer) (xsrc int) (ysrc int) (xdest int) (ydest int) (width int) (height int))) (gdk-draw-rectangle ((drawable c-pointer) (gc c-pointer) (filled boolean) (x int) (y int) (width int) (height int))) (gdk-gc-set-rgb-fg-color ((gc c-pointer) (color c-pointer))) (gdk-gc-set-rgb-bg-color ((gc c-pointer) (color c-pointer))) (gdk-color-parse ((spec c-string) (color c-pointer)) int) (gdk-draw-layout ((drawable c-pointer) (gc c-pointer) (x int) (y int) (pango-layout c-pointer))) (gdk-gc-set-line-attributes ((gc c-pointer) (line-width int) (line-style int) (cap-style int) (join-style int)))) --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gdk.h 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gdk.h 2008/01/28 23:59:42 1.1 /* GDK - The GIMP Drawing Kit * Copyright (C) 1995-1997 Peter Mattis, Spencer Kimball and Josh MacDonald * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library 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 GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. */ /* * Modified by the GTK+ Team and others 1997-2000. See the AUTHORS * file for a list of people on the GTK+ Team. See the ChangeLog * files for a list of changes. These files are distributed with * GTK+ at ftp://ftp.gtk.org/pub/gtk/. */ #ifndef __GDK_H__ #define __GDK_H__ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include G_BEGIN_DECLS /* Initialization, exit and events */ #define GDK_PRIORITY_EVENTS (G_PRIORITY_DEFAULT) void gdk_parse_args (gint *argc, gchar ***argv); void gdk_init (gint *argc, gchar ***argv); gboolean gdk_init_check (gint *argc, gchar ***argv); void gdk_add_option_entries_libgtk_only (GOptionGroup *group); void gdk_pre_parse_libgtk_only (void); #ifndef GDK_DISABLE_DEPRECATED void gdk_exit (gint error_code); #endif /* GDK_DISABLE_DEPRECATED */ gchar* gdk_set_locale (void); G_CONST_RETURN char *gdk_get_program_class (void); void gdk_set_program_class (const char *program_class); /* Push and pop error handlers for X errors */ void gdk_error_trap_push (void); gint gdk_error_trap_pop (void); #ifndef GDK_DISABLE_DEPRECATED void gdk_set_use_xshm (gboolean use_xshm); gboolean gdk_get_use_xshm (void); #endif /* GDK_DISABLE_DEPRECATED */ gchar* gdk_get_display (void); G_CONST_RETURN gchar* gdk_get_display_arg_name (void); #if !defined (GDK_DISABLE_DEPRECATED) || defined (GTK_COMPILATION) /* Used by gtk_input_add_full () */ gint gdk_input_add_full (gint source, GdkInputCondition condition, GdkInputFunction function, gpointer data, GdkDestroyNotify destroy); #endif /* !GDK_DISABLE_DEPRECATED || GTK_COMPILATION */ #ifndef GDK_DISABLE_DEPRECATED gint gdk_input_add (gint source, GdkInputCondition condition, GdkInputFunction function, gpointer data); void gdk_input_remove (gint tag); #endif /* GDK_DISABLE_DEPRECATED */ GdkGrabStatus gdk_pointer_grab (GdkWindow *window, gboolean owner_events, GdkEventMask event_mask, GdkWindow *confine_to, GdkCursor *cursor, guint32 time_); GdkGrabStatus gdk_keyboard_grab (GdkWindow *window, gboolean owner_events, guint32 time_); gboolean gdk_pointer_grab_info_libgtk_only (GdkDisplay *display, GdkWindow **grab_window, gboolean *owner_events); gboolean gdk_keyboard_grab_info_libgtk_only (GdkDisplay *display, GdkWindow **grab_window, gboolean *owner_events); #ifndef GDK_MULTIHEAD_SAFE void gdk_pointer_ungrab (guint32 time_); void gdk_keyboard_ungrab (guint32 time_); gboolean gdk_pointer_is_grabbed (void); gint gdk_screen_width (void) G_GNUC_CONST; gint gdk_screen_height (void) G_GNUC_CONST; gint gdk_screen_width_mm (void) G_GNUC_CONST; gint gdk_screen_height_mm (void) G_GNUC_CONST; void gdk_beep (void); #endif /* GDK_MULTIHEAD_SAFE */ void gdk_flush (void); #ifndef GDK_MULTIHEAD_SAFE void gdk_set_double_click_time (guint msec); #endif /* Rectangle utilities */ gboolean gdk_rectangle_intersect (GdkRectangle *src1, GdkRectangle *src2, GdkRectangle *dest); void gdk_rectangle_union (GdkRectangle *src1, GdkRectangle *src2, GdkRectangle *dest); GType gdk_rectangle_get_type (void) G_GNUC_CONST; #define GDK_TYPE_RECTANGLE (gdk_rectangle_get_type ()) /* Conversion functions between wide char and multibyte strings. */ #ifndef GDK_DISABLE_DEPRECATED gchar *gdk_wcstombs (const GdkWChar *src); gint gdk_mbstowcs (GdkWChar *dest, const gchar *src, gint dest_max); #endif /* Miscellaneous */ #ifndef GDK_MULTIHEAD_SAFE gboolean gdk_event_send_client_message (GdkEvent *event, GdkNativeWindow winid); void gdk_event_send_clientmessage_toall (GdkEvent *event); #endif gboolean gdk_event_send_client_message_for_display (GdkDisplay *display, GdkEvent *event, GdkNativeWindow winid); void gdk_notify_startup_complete (void); /* Threading */ #if !defined (GDK_DISABLE_DEPRECATED) || defined (GDK_COMPILATION) GDKVAR GMutex *gdk_threads_mutex; /* private */ #endif GDKVAR GCallback gdk_threads_lock; GDKVAR GCallback gdk_threads_unlock; void gdk_threads_enter (void); [23 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkalias.h 2008/01/28 23:59:42 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkalias.h 2008/01/28 23:59:42 1.1 [2419 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkinternals.h 2008/01/28 23:59:47 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkinternals.h 2008/01/28 23:59:47 1.1 [2807 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkintl.h 2008/01/28 23:59:47 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkintl.h 2008/01/28 23:59:47 1.1 [2859 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkkeysyms.h 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gdkkeysyms.h 2008/01/28 23:59:49 1.1 [4231 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-adds-hold.c 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-adds-hold.c 2008/01/28 23:59:49 1.1 [4380 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-adds.c 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-adds.c 2008/01/28 23:59:49 1.1 [4473 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-adds.def 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-adds.def 2008/01/28 23:59:49 1.1 [4485 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-button.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-button.lisp 2008/01/28 23:59:49 1.1 [4569 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-core.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-core.lisp 2008/01/28 23:59:49 1.1 [4695 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-ffi.asd 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-ffi.asd 2008/01/28 23:59:49 1.1 [4719 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-ffi.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-ffi.lisp 2008/01/28 23:59:49 1.1 [5141 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-ffi.lpr 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-ffi.lpr 2008/01/28 23:59:49 1.1 [5187 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-list-tree.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-list-tree.lisp 2008/01/28 23:59:49 1.1 [5382 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-menu.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-menu.lisp 2008/01/28 23:59:49 1.1 [5488 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-other.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-other.lisp 2008/01/28 23:59:49 1.1 [6376 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-tool.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-tool.lisp 2008/01/28 23:59:49 1.1 [6485 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-utilities.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/gtk-utilities.lisp 2008/01/28 23:59:49 1.1 [6757 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/hello-gtk-adds.c 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/hello-gtk-adds.c 2008/01/28 23:59:49 1.1 [6767 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/libcellsgtk.dll 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/libcellsgtk.dll 2008/01/28 23:59:49 1.1 [6776 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/package.lisp 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/package.lisp 2008/01/28 23:59:49 1.1 [6844 lines skipped] --- /project/cells/cvsroot/cells-gtk/gtk-ffi/specs.new 2008/01/28 23:59:49 NONE +++ /project/cells/cvsroot/cells-gtk/gtk-ffi/specs.new 2008/01/28 23:59:49 1.1 [6931 lines skipped] From ktilton at common-lisp.net Mon Jan 28 23:59:58 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 18:59:58 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/pod-utils Message-ID: <20080128235958.5404530034@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/pod-utils In directory clnet:/tmp/cvs-serv9292/pod-utils Added Files: kt-trace.lisp pod-utils.asd pod-utils.lpr utils.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/pod-utils/kt-trace.lisp 2008/01/28 23:59:50 NONE +++ /project/cells/cvsroot/cells-gtk/pod-utils/kt-trace.lisp 2008/01/28 23:59:50 1.1 ;;; Copyright (c) 2004 Kenny Tilton ;;; ;;; 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. ;;;----------------------------------------------------------------------- ;;; ;;; Kenny Tilton trace stuff. ;;; (in-package :pod-utils) (defparameter *trcdepth* 0) (defvar *count* nil) (defvar *counting* nil) (defvar *dbg*) (defvar *stop* nil) (defun utils-kt-reset () (setf *count* nil *stop* nil *dbg* nil *trcdepth* 0)) ;----------- trc ------------------------------------------- (defmacro count-it (&rest keys) `(when *counting* (call-count-it , at keys))) (defmacro trc (tgt-form &rest os &aux (wrapper (if (macro-function 'without-c-dependency) 'without-c-dependency 'progn))) (if (eql tgt-form 'nil) '(progn) (if (stringp tgt-form) `(,wrapper (call-trc t ,tgt-form , at os)) (let ((tgt (gensym))) `(,wrapper (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn (assert (stringp ,(car os))) (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os))) (progn ;;(break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) (defun call-trc (stream s &rest os) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) (format stream "~a" s) (let (pkwp) (dolist (o os) (format stream (if pkwp " ~s" " | ~s") o) (setf pkwp (keywordp o)))) (values)) (defun call-count-it (&rest keys) (declare (ignorable keys)) ;;; (when (eql :TGTNILEVAL (car keys))(break)) (let ((entry (assoc keys *count* :test #'equal))) (if entry (setf (cdr entry) (1+ (cdr entry))) (push (cons keys 1) *count*)))) ;; (export '(trc)) ;; clashes with cells:trc (trc back in cells for cells3) --- /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.asd 2008/01/28 23:59:58 NONE +++ /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.asd 2008/01/28 23:59:58 1.1 (asdf:defsystem :pod-utils :name "pod-utils" :components ((:file "utils") (:file "kt-trace"))) --- /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.lpr 2008/01/28 23:59:58 NONE +++ /project/cells/cvsroot/cells-gtk/pod-utils/pod-utils.lpr 2008/01/28 23:59:58 1.1 ;; -*- lisp-version: "8.1 [Windows] (Dec 2, 2007 6:32)"; cg: "1.103.2.10"; -*- (in-package :cg-user) (define-project :name :pod-utils :modules (list (make-instance 'module :name "utils.lisp") (make-instance 'module :name "kt-trace.lisp")) :projects nil :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :common-graphics-user :main-form nil :compilation-unit t :verbose nil :runtime-modules (list :cg-dde-utils :cg.acache :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.chart-or-plot :cg.chart-widget :cg.check-box :cg.choice-list :cg.choose-printer :cg.class-grid :cg.class-slot-grid :cg.class-support :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.object-editor :cg.object-editor.layout :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.scrolling-static-text :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags (list :top-level :debugger) :build-flags (list :allow-runtime-debug) :autoload-warning nil :full-recompile-for-runtime-conditionalizations nil :include-manifest-file-for-visual-styles t :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'default-init-function :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/cells-gtk/pod-utils/utils.lisp 2008/01/28 23:59:58 NONE +++ /project/cells/cvsroot/cells-gtk/pod-utils/utils.lisp 2008/01/28 23:59:58 1.1 ;;; Copyright (c) 2004 Peter Denno ;;; ;;; 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. ;;;----------------------------------------------------------------------- ;;; ;;; Peter Denno ;;; Date: 12/2/95 - on going. ;;; ;;; Generally applicable utilities. Some from Norvig's "Paradigms of ;;; Artificial Programming," Some from Kiczales et. al. "The Art of the ;;; Metaobject Protocol," some from Graham's "On Lisp," some from Sam Steingold. ;;; (in-package :cl-user) (defpackage pod-utils (:nicknames pod) (:use cl) (:export combinations flatten kintern sintern mapappend pairs memo debug-memo memoize clear-memoize defun-memoize VARS mac mac2 load-ht when-bind if-bind when-bind* substring remove-extra-spaces break-line-at read-string-to-list split name2initials c-name2lisp lisp-name2c single-p mklist longer group prune find2 before duplicate split-if mvb mvs dbind decode-time-interval strcat now tree-search depth-first-search prepend breadth-first-search update with-stack-size pprint-without-strings chop setx new-reslist reslist-pop reslist-push reslist-fillptr reuse-cons intersect-predicates defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns system-forget-memoized-fns with-gensyms last1 fail)) (in-package :pod-utils) ;;; Purpose: Return the combinations possible when selecting one item ;;; from each of the argument sets. ;;; Example: (combinations '(a) '(b c) '(d e)) ;;; => ((A B D) (A B E) (A C D) (A C E)) ;;; Arg: sets - lists ;;; Value: a list of lists. If the argument is nil, it returns nil. (defun combinations (&rest sets) (cond ((null sets) nil) (t (flet ((combinations-aux (aset bset) (cond ((not aset) bset) ((not bset) aset) (t (loop for a in aset append (loop for b in bset collect (list a b))))))) (loop for set in (reduce #'combinations-aux sets) collect (flatten set)))))) (defun flatten (input &optional accumulator) "Return a flat list of the atoms in the input. Ex: (flatten '((a (b (c) d))) => (a b c d))" (cond ((null input) accumulator) ((atom input) (cons input accumulator)) (t (flatten (first input) (flatten (rest input) accumulator))))) (declaim (inline kintern)) (defun kintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the KEYWORD package." (intern (string-upcase (apply #'format nil (string string) args)) (find-package "KEYWORD"))) (declaim (inline sintern)) (defun sintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the current (*PACKAGE*) package." (intern (string-upcase (apply #'format nil (string string) args)))) (defun mapappend (fun &rest args) (loop until (some #'null args) append (apply fun (loop for largs on args collect (pop (first largs)))))) (defun mapnconc (fun &rest args) (loop until (some #'null args) nconc (apply fun (loop for largs on args collect (pop (first largs)))))) ;;; Purpose: Return a list of pairs of elements from the argument list: ;;; Ex: (pairs '(a b c d)) => ((a b) (a c) (a d) (b c) (b d) (c d)) ;;; ;;; Args: inlist - a list (defun pairs (inlist) (loop for sublist on inlist while (cdr sublist) append (loop for elem in (cdr sublist) collect `(,(first sublist) ,elem)))) ;;; Purpose: Called by memoize, below. This returns ;;; the memoized function. Norvig, Page 270. ;;; When you want to use this on &rest args use :test #'equal :key #'identity ;;; Args: fn - the function object. ;;; name - the function symbol. ;;; key - On what argument the result is indexed. ;;; test - Either eql or equal, the :test of the hash table. (defun memo (fn name key test) "Return a memo-function of fn." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p val (setf (gethash k table) (apply fn args)))))))) (defun debug-memo (fn name key test) "Like memo but prints *hit* on every hit." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p (progn (princ " *HIT*") val) (progn (princ " *miss*") (setf (gethash k table) (apply fn args))))))))) ;;; Purpose: memoize the argument function. ;;; Arguments as those in memo. (defun memoize (fn-name &key (key #'first) (test #'eql) (debug nil)) "Replace fn-name's global definition with a memoized version." #-Allegro-V4.3 (format t "~%;;; Memoizing (~a) ~a ****" test fn-name) #+Allegro-V4.3 (format t "~%;;; Memoizing ~a ****" fn-name) (if debug (setf (symbol-function fn-name) (debug-memo (symbol-function fn-name) fn-name key test)) (setf (symbol-function fn-name) (memo (symbol-function fn-name) fn-name key test)))) ;;; Clear the hash table from the function. (defun clear-memoize (fn-name) "Clear the hash table from a memo function." (let ((table (get fn-name 'memo))) (when table (clrhash table)))) ;;; Purpose: define a function and memoize it. ;;; Limitations: only useful for default arguments, i.e., ;;; key on first and test eql. In all other ;;; cases call (memoize :key :test ). (defmacro defun-memoize (fn args &body body) `(memoize (defun ,fn ,args ,body))) ;;; Stuff to use when you have a serious number of memoized functions, ;;; and you have a notion of "starting over." (defmacro defmemo (fname &body body) `(progn (defun ,fname , at body) (eval-when (:load-toplevel) (memoize ',fname) (system-add-memoized-fn ',fname)))) (let ((+memoized-fns+ nil)) (defun system-clear-memoized-fns () (mapcar #'(lambda (x) (warn "Clearing memoized ~A" x) (clear-memoize x)) +memoized-fns+)) (defun system-add-memoized-fn (fname) (pushnew fname +memoized-fns+)) (defun system-list-memoized-fns () +memoized-fns+) (defun system-forget-memoized-fns () (setf +memoized-fns+ nil)) ) ;;; Purpose: Diagnostic (From Howard Stearns) that does ;;; (vars a b c) => (FORMAT *TRACE-OUTPUT* "~&a = ~S b = ~S c = ~S ~%" A B C) (defmacro VARS (&rest variables) `(format *trace-output* ,(loop with result = "~&" for var in variables do (setf result (if (and (consp var) (eq (first var) 'quote)) (concatenate 'string result " ~S ") (concatenate 'string result (string-downcase var) " = ~S "))) finally (return (concatenate 'string result "~%"))) , at variables)) ;;; The most essential macro building tool. (defmacro mac (macro) `(pprint (macroexpand-1 ',macro))) ;;; Similar, but used on 'subtype' macros. (defmacro mac2 (macro) `(pprint (macroexpand-1 (macroexpand-1 ',macro)))) ;;; Dirk H.P. Gerrits' "Lisp Code Walker" slides, ALU Meeting, Amsterdam, 2003. ;;; With additional corrections (beyond that in his notes). [495 lines skipped] From ktilton at common-lisp.net Tue Jan 29 00:00:33 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 19:00:33 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/root Message-ID: <20080129000033.A0E3E6303A@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/root In directory clnet:/tmp/cvs-serv9292/root Added Files: INSTALL.TXT asdf.lisp config.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/root/INSTALL.TXT 2008/01/29 00:00:29 NONE +++ /project/cells/cvsroot/cells-gtk/root/INSTALL.TXT 2008/01/29 00:00:29 1.1 You don't need to read this file if you are installing from a snapshot tarball. This only concerns the situation where you get the pieces cells, hello-c, cells-gtk etc, individually. ############################################################################################################# The notes below apply to the UFFI port of Cells-gtk done by Ken Tilton. (Actually I have forked UFFI and call it Hello-C, but the idea is the same: portable FFI.) For the original version by Vasilis Margioulas, which uses native CLisp FFI to good advantage, grab this: http://common-lisp.net/cgi-bin/viewcvs.cgi/cells-gtk/clisp-cgtk/clisp-cgtk.tar.gz?tarball=1&cvsroot=cells-gtk ...and follow the INSTALL.TXT in that. ############################################################################################################## Dependencies: Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.tar.gz?tarball=1&cvsroot=cells Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.tar.gz?tarball=1&cvsroot=cells Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz?tarball=1&cvsroot=cells On windows install Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zip?download Add the gtk libs to your PATH variable: Start>Settings>Control Panel>System>Advanced>Environment Variables> Then select PATH and hit "Edit". Append to existing value: "C:\Program Files\Common Files\GTK\2.0\bin"; ..prior values... Edit load.lisp and follow the instructions there. No, you cannot just load it. Note: On windows under emacs with slime, the gtk window does not popup. You must start the application from a dos prompt. Tested on: Windows xp with gtk 2.4.10 and clisp 2.33, using AllegroCL 6.2 Enterprise and Lispworks 4.3 Personal Known bugs: On Windows: Clisp crash 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/root/asdf.lisp 2008/01/29 00:00:33 NONE +++ /project/cells/cvsroot/cells-gtk/root/asdf.lisp 2008/01/29 00:00:33 1.1 ;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical ;;; source for asdf is presently the cCLan CVS repository at ;;; ;;; ;;; 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 "~@" (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 ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) (operation-times :initform (make-hash-table ) :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) ;;;; methods: components (defmethod print-object ((c missing-component) s) (format s "~@" (missing-requires c) (missing-version c) (when (missing-parent c) (component-name (missing-parent c))))) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity t) (ignore-errors (prin1 (component-name c) stream)))) (defclass module (component) ((components :initform nil :accessor module-components :initarg :components) ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail :accessor module-if-component-dep-fails :initarg :if-component-dep-fails) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) (defgeneric component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) (defun component-parent-pathname (component) (aif (component-parent component) (component-pathname it) *default-pathname-defaults*)) (defgeneric component-relative-pathname (component) (:documentation "Extracts the relative pathname applicable for a particular component.")) (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname :directory `(:relative ,(component-name component)) :host (pathname-host (component-parent-pathname component))))) (defmethod component-pathname ((component component)) (let ((*default-pathname-defaults* (component-parent-pathname component))) (merge-pathnames (component-relative-pathname component)))) (defgeneric component-property (component property)) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) (defgeneric (setf component-property) (new-value component property)) (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a (setf (cdr a) new-value) (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties)))))) (defclass system (module) ((description :accessor system-description :initarg :description) (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence))) ;;; version-satisfies ;;; with apologies to christophe rhodes ... (defun split (string &optional max (ws '(#\Space #\Tab))) (flet ((is-ws (char) (find char ws))) (nreverse (let ((list nil) (start 0) (words 0) end) (loop (when (and max (>= words (1- max))) (return (cons (subseq string start) list))) (setf end (position-if #'is-ws string :start start)) (push (subseq string start end) list) (incf words) (unless end (return list)) (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (let ((x (mapcar #'parse-integer (split (component-version c) nil '(#\.)))) (y (mapcar #'parse-integer (split version nil '(#\.))))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems (defvar *defined-systems* (make-hash-table :test 'equal)) (defun coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error "~@" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- (defvar *system-definition-search-functions* '(sysdef-central-registry-search)) (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) *system-definition-search-functions*)) (defvar *central-registry* '(*default-pathname-defaults* #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" #+nil "telent:asdf;systems;")) (defun sysdef-central-registry-search (system) (let ((name (coerce-name system))) (block nil (dolist (dir *central-registry*) (let* ((defaults (eval dir)) (file (and defaults (make-pathname :defaults defaults :version :newest :name name :type "asd" :case :local)))) (if (and file (probe-file file)) [755 lines skipped] --- /project/cells/cvsroot/cells-gtk/root/config.lisp 2008/01/29 00:00:33 NONE +++ /project/cells/cvsroot/cells-gtk/root/config.lisp 2008/01/29 00:00:33 1.1 [799 lines skipped] From ktilton at common-lisp.net Tue Jan 29 00:00:41 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 19:00:41 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/test-gtk Message-ID: <20080129000041.59746490A7@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv9292/test-gtk Added Files: cells3-porting-notes.lisp test-addon.lisp test-buttons.lisp test-dialogs.lisp test-display.lisp test-entry.lisp test-gtk.asd test-gtk.lisp test-gtk.lpr test-layout.lisp test-menus.lisp test-textview.lisp test-tree-view.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/test-gtk/cells3-porting-notes.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/cells3-porting-notes.lisp 2008/01/29 00:00:40 1.1 #| 1. TRC is now back in the cells package. pod-utils no longer exports TRC. use pod::trc to get to it. We could probably just drop TRC from pod-utils. 2. def-c-output is now defobserver. name change only. 3. md-value/.md-value is now value/.value 4. Use :owning option on cell slot to handle things like: popup tree-model |# (in-package :cells-gtk) (export '(make-be)) (defun make-be (class &rest args) (md-awaken (apply 'make-instance class args))) (defun to-be (x) (md-awaken x))--- /project/cells/cvsroot/cells-gtk/test-gtk/test-addon.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-addon.lisp 2008/01/29 00:00:40 1.1 (in-package :test-gtk) (defmodel test-addon (notebook) () (:default-initargs :tab-labels (list "Calendar" "Arrows") :kids (kids-list? (mk-vbox :kids (kids-list? (mk-calendar :md-name :calendar :init (encode-universal-time 0 0 0 6 3 1971)) (mk-label :text (c? (when (value (fm^ :calendar)) (multiple-value-bind (sec min hour day month year) (decode-universal-time (value (fm^ :calendar))) (declare (ignorable sec min hour)) (format nil "Day selected ~a/~a/~a" day month year))))))) (mk-vbox :kids (kids-list? (mk-arrow :type (c? (value (fm^ :type)))) (mk-frame :label "Arrow type" :kids (kids-list? (mk-hbox :md-name :type :kids (kids-list? (mk-radio-button :md-name :up :label "Up") (mk-radio-button :md-name :down :label "Down") (mk-radio-button :md-name :left :label "Left") (mk-radio-button :md-name :right :label "Right" :init t)))))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/29 00:00:40 1.1 (in-package :test-gtk) (defmodel test-buttons (vbox) ((nclics :accessor nclics :initform (c-in 0))) (:default-initargs :kids (c? (the-kids (mk-label :text (c? (format nil "Toggled button active = ~a" (value (fm-other :toggled-button))))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" (value (fm-other :check-button))))) (mk-hseparator) (mk-label :text (c? (format nil "Radio button selected = ~a" (value (fm-other :radio-group))))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" (nclics (upper self test-buttons)))) :selectable t) (mk-hseparator) (mk-hbox :kids (c? (the-kids (mk-button :stock :apply :tooltip "Click ....." :on-clicked (callback (widget event data) (incf (nclics (upper self test-buttons))))) (mk-button :label "Continuable error" :on-clicked (callback (widget event data) (error 'gtk-continuable-error :text "Oops!"))) (mk-toggle-button :md-name :toggled-button :markup (c? (with-markup (:foreground (if (value self) :red :blue)) "_Toggled Button"))) (mk-check-button :md-name :check-button :markup (with-markup (:foreground :green) "_Check Button"))))) (mk-hbox :md-name :radio-group :kids (c? (the-kids (mk-radio-button :md-name :radio-1 :label "Radio 1") (mk-radio-button :md-name :radio-2 :label "Radio 2" :init t) (mk-radio-button :md-name :radio-3 :label "Radio 3")))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/29 00:00:40 1.1 (in-package :test-gtk) (defmodel test-message (button) ((message-type :accessor message-type :initarg :message-type :initform nil)) (:default-initargs :label (c? (string-downcase (symbol-name (message-type self)))) :on-clicked (callback (widget signal data) (setf (text (fm^ :message-response)) (format nil "Dialog response ~a" (show-message (format nil "~a message" (label self)) :message-type (message-type self))))))) (defmodel test-file-chooser-dialog (button) ((action :accessor action :initarg :action :initform nil)) (:default-initargs :stock (c? (action self)) ; :label (c? (string-downcase (symbol-name (action self)))) :on-clicked (callback (widget signal data) (with-integrity (:change 'on-click-cb) (setf (text (fm^ :file-chooser-response)) (format nil "File chooser response ~a" (file-chooser :title (format nil "~a dialog" (action self)) :select-multiple (value (fm^ :select-multiple-files)) :action (action self)))))))) (defmodel test-dialogs (vbox) () (:default-initargs :kids (kids-list? (mk-hbox :kids (kids-list? (append #-libcellsgtk nil #+libcellsgtk (list (mk-button :label "Query for text" :on-clicked (callback (w e d) (let ((dialog (to-be (mk-message-dialog :md-name :rule-name-dialog :message "Type something:" :title "My Title" :message-type :question :buttons-type :ok-cancel :content-area (mk-entry :auto-aupdate t))))) (setf (text (fm^ :message-response)) (value dialog)))))) (loop for message-type in '(:info :warning :question :error) collect (make-kid 'test-message :message-type message-type))))) (mk-label :md-name :message-response) (mk-hbox :kids (kids-list? (mk-check-button :md-name :select-multiple-files :label "Select multiple") (loop for action in '(:open :save :select-folder :create-folder) collect (make-kid 'test-file-chooser-dialog :action action)))) (mk-label :md-name :file-chooser-response) (mk-notebook :expand t :fill t :tab-labels (list "Open" "Save" "Select folder" "Create folder") :kids (kids-list? (loop for action in '(:open :save :select-folder :create-folder) collect (mk-vbox :kids (kids-list? (mk-file-chooser-widget :md-name action :action action :expand t :fill t :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) :select-multiple (c? (value (fm^ :multiple)))) (mk-check-button :label "Select multiple" :md-name :multiple) (mk-label :text (c? (format nil "~a ~a" (md-name (psib (psib))) (value (psib (psib)))))))))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-display.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-display.lisp 2008/01/29 00:00:40 1.1 (in-package :test-gtk) (defmodel test-display (vbox) () (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false. :value (c? (when (value (fm-other :pulse)) (timeout-add (value (fm-other :timeout)) (lambda () (pulse (fm-other :pbar2)) (value (fm-other :pulse)))))) :expand t :fill t :kids (kids-list? (mk-hbox :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect (mk-image :stock :harddisk :icon-size icon-size) collect (mk-image :stock :my-g :icon-size icon-size))) (mk-hseparator) (mk-aspect-frame :ratio 1 :kids (kids-list? (mk-image :width 200 :height 250 :filename (namestring *tst-image*)))) (mk-hseparator) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar :fraction (c? (value (fm^ :fraction-value)))) (mk-hscale :md-name :fraction-value :value-type 'single-float :min 0 :max 1 :step 0.01 :init 0.5) (mk-button :label "Show in status bar" :on-clicked (callback (widget event data) (push-message (fm-other :statusbar) (format nil "~a" (fraction (fm-other :pbar)))))))) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar2 :pulse-step (c? (value (fm^ :step))) :fraction (c-in .1)) (mk-toggle-button :md-name :pulse :label "Pulse") (mk-label :text "Interval") (mk-spin-button :md-name :timeout :sensitive (c? (not (value (fm^ :pulse)))) :min 10 :max 1000 :init 100) (mk-label :text "Pulse step") (mk-spin-button :md-name :step :value-type 'single-float :min 0.01 :max 1 :step 0.01 :init 0.1) (mk-image :md-name :pulse-image :stock (c? (if (value (fm^ :pulse)) :yes :no))))) (mk-alignment :expand t :fill t :xalign 0 :yalign 1 :xscale 1 :kids (c? (the-kids (mk-statusbar :md-name :statusbar))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-entry.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-entry.lisp 2008/01/29 00:00:40 1.1 (in-package :test-gtk) (defmodel test-entry (vbox) () (:default-initargs :kids (kids-list? (mk-vbox :kids (test-entry-1)) (mk-check-button :md-name :cool :init t :label "Cool") (mk-frame :kids (test-entry-2)) (mk-hbox :kids (kids-list? (mk-spin-button :md-name :spin :init 10))) (mk-hbox :kids (kids-list? (mk-label :text "Entry completion test (press i)") (mk-entry :max-length 20 :completion (loop for i from 1 to 10 collect (format nil "Item ~d" i)))))))) (defun test-entry-1 () (c? (the-kids (mk-label :expand t :fill t :markup (c? (with-markup (:font-desc "24") (with-markup (:foreground :blue :font-family "Arial" :font-desc (if (value (fm-other :spin)) (truncate (value (fm-other :spin))) 10)) (value (fm-other :entry))) (with-markup (:underline :double :weight :bold :foreground :red :font-desc (if (value (fm-other :hscale)) (truncate (value (fm-other :hscale))) 10)) "is") (with-markup (:strikethrough (value (fm^ :cool))) "boring") (with-markup (:strikethrough (not (value (fm^ :cool)))) "cool!"))) :selectable t) (mk-entry :md-name :entry :auto-aupdate t :init "Testing")))) (defun test-entry-2 () (c? (the-kids (mk-vbox :kids (c? (the-kids (mk-hbox :kids (kids-list? (mk-check-button :md-name :sensitive :label "Sensitive") (mk-check-button :md-name :visible :init t :label "Visible"))) (mk-hscale :md-name :hscale :visible (c? (value (fm^ :visible))) :sensitive (c? (value (fm^ :sensitive))) :expand t :fill t :min 0 :max 100 :init 10))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.asd 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.asd 2008/01/29 00:00:40 1.1 (asdf:defsystem :test-gtk :name "test-gtk" :depends-on (:cells-gtk) :serial t :components ((:file "test-gtk") (:file "test-layout") (:file "test-display") (:file "test-buttons") (:file "test-entry") (:file "test-tree-view") (:file "test-menus") (:file "test-dialogs") (:file "test-textview") (:file "test-addon") )) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/29 00:00:40 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/29 00:00:40 1.1 (defpackage :test-gtk (:use :common-lisp :pod :cells :gtk-ffi :cells-gtk) (:export gtk-demo)) (in-package :test-gtk) (defvar *test-img-dir* (make-pathname :name nil :type nil :version nil :defaults (merge-pathnames (make-pathname :directory '(:relative :back :back "test-images")) (parse-namestring *load-truename*)))) (defvar *splash-image* (make-pathname :name "splash" :type "png" :defaults *test-img-dir*)) (defvar *small-image* (make-pathname :name "small" :type "png" :defaults *test-img-dir*)) (defvar *stock-icon-image* (make-pathname :name "my-g" :type "png" :defaults *test-img-dir*)) (defvar *tst-image* (make-pathname :name "tst" :type "gif" :defaults *test-img-dir*)) (defmodel test-gtk (gtk-app) () (:default-initargs :title "GTK Testing" ;;:tooltips nil ;;dkwt ;;:tooltips-enable nil ;;dkwt :icon (namestring *small-image*) :stock-icons (list (list :my-g (namestring *stock-icon-image*))) :position :center :splash-screen-image (namestring *splash-image*) :width 650 :height 550 :kids (c? (the-kids (let ((tabs '("Buttons" "Display" "Layout" "Menus" "Textview" "Dialogs" "Addon" "Entry" "Tree-view" ))) (list (mk-notebook :tab-labels tabs :kids (c? (the-kids (loop for test-name in tabs collect (make-instance (intern (string-upcase (format nil "test-~a" test-name)) :test-gtk) :fm-parent *parent*))))))))))) (defun test-gtk-app () (start-app 'test-gtk) #+clisp (ext:exit)) (defun gtk-demo (&optional dbg) (ukt:test-prep) (cells-gtk-init) (cells-gtk:start-app 'test-gtk::test-gtk :debug dbg)) ;(ext:saveinitmem "test-gtk.mem" :init-function 'test-gtk::test-gtk-app) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lpr 2008/01/29 00:00:41 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lpr 2008/01/29 00:00:41 1.1 ;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- (in-package :cg-user) (defpackage :TEST-GTK (:export #:gtk-demo)) (define-project :name :test-gtk :modules (list (make-instance 'module :name "test-gtk.lisp") (make-instance 'module :name "test-layout.lisp") [35 lines skipped] --- /project/cells/cvsroot/cells-gtk/test-gtk/test-layout.lisp 2008/01/29 00:00:41 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-layout.lisp 2008/01/29 00:00:41 1.1 [99 lines skipped] --- /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/29 00:00:41 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/29 00:00:41 1.1 [259 lines skipped] --- /project/cells/cvsroot/cells-gtk/test-gtk/test-textview.lisp 2008/01/29 00:00:41 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-textview.lisp 2008/01/29 00:00:41 1.1 [341 lines skipped] --- /project/cells/cvsroot/cells-gtk/test-gtk/test-tree-view.lisp 2008/01/29 00:00:41 NONE +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-tree-view.lisp 2008/01/29 00:00:41 1.1 [532 lines skipped] From ktilton at common-lisp.net Tue Jan 29 04:29:54 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 23:29:54 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080129042954.AC3605C198@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv21938 Modified Files: cell-types.lisp cells.lisp fm-utilities.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp synapse-types.lisp trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2007/12/03 20:11:11 1.27 +++ /project/cells/cvsroot/cells/cell-types.lisp 2008/01/29 04:29:52 1.28 @@ -66,8 +66,9 @@ (call-next-method) (progn (c-print-value c stream) - (format stream "=~d/~a/~a]" + (format stream "=~d/~a/~a/~a]" (c-pulse c) + (c-state c) (symbol-name (or (c-slot-name c) :anoncell)) (print-cell-model (c-model c)))))))) @@ -92,8 +93,6 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) - - ; --- ephemerality -------------------------------------------------- ; ; Not a type, but an option to the :cell parameter of defmodel --- /project/cells/cvsroot/cells/cells.lisp 2007/11/30 22:29:06 1.22 +++ /project/cells/cvsroot/cells/cells.lisp 2008/01/29 04:29:52 1.23 @@ -54,6 +54,7 @@ (defun c-stop (&optional why) (setf *stop* t) + (print `(c-stop-entry ,why)) (format t "~&C-STOP> stopping because ~a" why) ) (define-symbol-macro .stop @@ -151,13 +152,11 @@ (defun c-break (&rest args) (unless *stop* - (let ((*print-level* 3) + (let ((*print-level* 5) (*print-circle* t) - ) + (args2 (mapcar 'princ-to-string args))) (c-stop args) - (format t "c-break > stopping > ~a" args) - (apply 'error args)))) - - - - + + (format t "~&c-break > stopping > ~{~a ~}" args2) + (print `(c-break-args , at args2)) + (apply 'error args2)))) \ No newline at end of file --- /project/cells/cvsroot/cells/fm-utilities.lisp 2007/11/30 16:51:18 1.16 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/01/29 04:29:52 1.17 @@ -33,7 +33,8 @@ (apply #'make-instance part-class (append initargs (list :md-name partname))))) (defmacro mk-part (md-name (md-class) &rest initargs) - `(make-part ',md-name ',md-class , at initargs)) + `(make-part ',md-name ',md-class , at initargs + :fm-parent (progn (assert self) self))) (defmethod make-part-spec ((part-class symbol)) (make-part part-class part-class)) --- /project/cells/cvsroot/cells/link.lisp 2007/11/30 16:51:18 1.24 +++ /project/cells/cvsroot/cells/link.lisp 2008/01/29 04:29:52 1.25 @@ -23,7 +23,9 @@ (trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used) (return-from record-caller nil)) (trc nil "record-caller entry: used=" used :caller caller) - + #+cool (when (and (eq :ccheck (md-name (c-model caller))) + (eq :cview (md-name (c-model used)))) + (break "bingo")) (multiple-value-bind (used-pos useds-len) (loop with u-pos for known in (cd-useds caller) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 22:29:06 1.36 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/29 04:29:52 1.37 @@ -23,6 +23,8 @@ (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) (when (mdead self) (trc "md-slot-value passed dead self, returning NIL" self) + (inspect self) + (break "see inspector for dead ~a" self) (return-from md-slot-value nil)) (tagbody retry @@ -73,7 +75,7 @@ ; (declare (ignorable debug-id ensurer)) (count-it :ensure-value-is-current) - (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id ensurer) + ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c)) @@ -110,14 +112,15 @@ t)))))) (assert (typep c 'c-dependent)) (check-reversed (cd-useds c)))) - #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c) + #+shhh (trc c "kicking off calc-set of" (c-state c) (c-validp c) (c-slot-name c) :vstate (c-value-state c) :stamped (c-pulse c) :current-pulse *data-pulse-id*) (calculate-and-set c)) ((mdead (c-value c)) - (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) + (trc nil "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) (let ((new-v (calculate-and-set c))) - (trc "ensure-value-is-current> GOT new value ~a" new-v))) + (trc nil "ensure-value-is-current> GOT new value ~a to replace dead!!" new-v) + new-v)) (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) (c-pulse-update c :valid-uninfluenced))) @@ -128,7 +131,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (brk "ensure-value still got and still not returning ~a dead value ~a" c v) + (brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) nil) v))) @@ -162,8 +165,14 @@ (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" c raw-value)) - (md-slot-value-assume c raw-value propagation-code)))) - (if nil ;; *dbg* + (unless (c-optimized-away-p c) + ; this check for optimized-away-p arose because a rule using without-c-dependency + ; can be re-entered unnoticed since that clears *call-stack*. If re-entered, a subsequent + ; re-exit will be of an optimized away cell, which we need not sv-assume on... a better + ; fix might be a less cutesy way of doing without-c-dependency, and I think anyway + ; it would be good to lose the re-entrance. + (md-slot-value-assume c raw-value propagation-code))))) + (if (trcp c) ;; *dbg* (wtrc (0 100 "calcnset" c) (body)) (body)))) @@ -171,7 +180,7 @@ (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) (assert (typep c 'c-ruled)) - #+slow (trc *c-debug* "calculate-and-link" c) + #+shhh (trc c "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) @@ -236,6 +245,7 @@ (md-slot-value-assume c new-value nil)) (*defer-changes* + (print `(cweird ,c ,(type-of c))) (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) (t @@ -250,6 +260,7 @@ (defmethod md-slot-value-assume (c raw-value propagation-code) (assert c) + #+shhh (trc c "md-slot-value-assume entry" (c-state c)) (without-c-dependency (let ((prior-state (c-value-state c)) (prior-value (c-value c)) @@ -266,9 +277,12 @@ (return-from md-slot-value-assume absorbed-value)) ; --- slot maintenance --- + (when (eq (c-state c) :optimized-away) + (break "bongo one ~a flush ~a" c (flushed? c))) (unless (c-synaptic c) (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value)) - + (when (eq (c-state c) :optimized-away) + (break "bongo two ~a flush ~a" c (flushed? c))) ; --- cell maintenance --- (setf (c-value c) absorbed-value @@ -299,7 +313,11 @@ ;---------- optimizing away cells whose dependents all turn out to be constant ---------------- ; +(defun flushed? (c) + (rassoc c (cells-flushed (c-model c)))) + (defun c-optimize-away?! (c) + #+shhh (trc c "c-optimize-away?! entry" (c-state c) c) (when (and (typep c 'c-dependent) (null (cd-useds c)) (cd-optimize c) @@ -309,21 +327,27 @@ (not (c-inputp c)) ;; yes, dependent cells can be inputp ) ;; (when (trcp c) (break "go optimizing ~a" c)) - (trc nil "optimizing away" c (c-state c)) + + #+shh (when (trcp c) + (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c)))) + ) + (count-it :c-optimized) (setf (c-state c) :optimized-away) (let ((entry (rassoc c (cells (c-model c))))) (unless entry - (describe c)) + (describe c) + (bwhen (fe (rassoc c (cells-flushed (c-model c)))) + (trc "got in flushed thoi!" fe))) (c-assert entry) - (trc nil "c-optimize-away?! moving cell to flushed list" c) + ;(trc (eq (c-slot-name c) 'cgtk::id) "c-optimize-away?! moving cell to flushed list" c) (setf (cells (c-model c)) (delete entry (cells (c-model c)))) #-its-alive! (push entry (cells-flushed (c-model c))) ) - (dolist (caller (c-callers c)) + (dolist (caller (c-callers c) ) ; ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got ; kicked off and asked about the value of a dead instance. That returns nil, and @@ -332,6 +356,7 @@ ; so we ended up here. where there used to be a break. ; (setf (cd-useds caller) (delete c (cd-useds caller))) + ;;; (trc "nested opti" c caller) (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...) ))) --- /project/cells/cvsroot/cells/md-utilities.lisp 2007/11/30 16:51:18 1.13 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/01/29 04:29:52 1.14 @@ -40,7 +40,6 @@ nil)) (defgeneric not-to-be (self) - (:method ((self model-object)) (md-quiesce self)) --- /project/cells/cvsroot/cells/model-object.lisp 2007/11/30 16:51:18 1.16 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/01/29 04:29:52 1.17 @@ -106,6 +106,9 @@ (when (eql :nascent (md-state self)) (call-next-method))) +#+test +(md-slot-cell-type 'cgtk::label 'cgtk::container) + (defmethod md-awaken ((self model-object)) ; ; --- debug stuff @@ -123,7 +126,7 @@ (setf (md-state self) :awakening) (dolist (esd (class-slots (class-of self))) - (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) + (bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd))) (let* ((slot-name (slot-definition-name esd)) (c (md-slot-cell self slot-name))) (when *c-debug* @@ -146,6 +149,7 @@ ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed ;; but first I worried about it being slow keeping the flushed list /and/ searching, then ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)) @@ -175,6 +179,9 @@ (cdr (assoc slot-name (cells self))) (get slot-name 'cell))) +#+test +(get 'cgtk::label :cell-types) + (defun md-slot-cell-type (class-name slot-name) (assert class-name) (if (eq class-name 'null) @@ -192,11 +199,11 @@ (setf (get slot-name :cell-type) new-type) (let ((entry (assoc slot-name (get class-name :cell-types)))) (if entry - (progn + (prog1 (setf (cdr entry) new-type) (loop for c in (class-direct-subclasses (find-class class-name)) do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) - (push (cons slot-name new-type) (get class-name :cell-types)))))) + (cdar (push (cons slot-name new-type) (get class-name :cell-types))))))) (defun md-slot-owning (class-name slot-name) (assert class-name) --- /project/cells/cvsroot/cells/synapse-types.lisp 2007/11/30 16:51:18 1.6 +++ /project/cells/cvsroot/cells/synapse-types.lisp 2008/01/29 04:29:52 1.7 @@ -36,7 +36,7 @@ (defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn) (with-synapse synapse-id (prior-fire-value) (let ((new-value (funcall body-fn))) - (trc nil "f-sensitivity fire-p decides" prior-fire-value sensitivity) + ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity) (let ((prop-code (if (or (xor prior-fire-value new-value) (eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity) (delta-greater-or-equal --- /project/cells/cvsroot/cells/trc-eko.lisp 2007/11/30 16:51:18 1.7 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 04:29:52 1.8 @@ -33,7 +33,7 @@ `(without-c-dependency (call-trc t ,tgt-form , at os)) (let ((tgt (gensym))) - ;(break "slowww? ~a" tgt-form) + (break "slowww? ~a" tgt-form) `(without-c-dependency (bif (,tgt ,tgt-form) (if (trcp ,tgt) @@ -64,7 +64,7 @@ '(progn) `(without-c-dependency (call-trc t ,(format nil "TX> ~(~s~)" tgt-form) - ,@(loop for obj in os + ,@(loop for obj in (or os (list tgt-form)) nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) From ktilton at common-lisp.net Tue Jan 29 04:29:54 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 23:29:54 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20080129042954.E0F785D089@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv21938/gui-geometry Modified Files: defpackage.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/07/03 00:08:29 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2008/01/29 04:29:54 1.7 @@ -19,7 +19,8 @@ (:use #:common-lisp #:utils-kt #:cells) (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb - #:^px #:^py #:^ll #:^lt #:^lr #:^lb + #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height + #:^fill-parent-down #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds #:mkr #:v2-nmove #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h #:r-bounds #:l-box From ktilton at common-lisp.net Tue Jan 29 04:29:55 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 28 Jan 2008 23:29:55 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080129042955.453845E006@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv21938/utils-kt Modified Files: debug.lisp detritus.lisp flow-control.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/12/03 12:21:01 1.16 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/01/29 04:29:55 1.17 @@ -61,7 +61,8 @@ (defun call-count-it (&rest keys) (declare (ignorable keys)) - ;;; (when (eql :TGTNILEVAL (car keys))(break)) + (when (find (car keys) '(:trcfailed :TGTNILEVAL)) + (break "clean up time ~a" keys)) (let ((entry (assoc keys *count* :test #'equal))) (if entry (setf (cdr entry) (1+ (cdr entry))) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/12/03 20:11:12 1.16 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/01/29 04:29:55 1.17 @@ -59,24 +59,28 @@ (defun collect-if (test list) (remove-if-not test list)) -#-iamnotkenny -(defun test-setup () - #-its-alive! +(defun test-setup (&optional drib) + #-(or iamnotkenny its-alive!) (ide.base::find-new-prompt-command - (cg.base::find-window :listener-frame))) + (cg.base::find-window :listener-frame)) + (when drib + (dribble (merge-pathnames + (make-pathname :name drib :type "TXT") + (project-path))))) + +(export! project-path) +(defun project-path () + (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) #+test (test-setup) -#-iamnotkenny -(defun test-prep () - (test-setup)) - -#-iamnotkenny -(defun test-init () - (test-setup)) +(defun test-prep (&optional drib) + (test-setup drib)) + +(defun test-init (&optional drib) + (test-setup drib)) -#-iamnotkenny (export! test-setup test-prep test-init) ;;; --- FIFO Queue ----------------------------- --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/11/30 16:51:20 1.11 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/01/29 04:29:55 1.12 @@ -124,6 +124,27 @@ `(loop for ,nvar below ,count collecting (progn , at body))) +(export! maphash* hashtable-assoc -1?1 -1?1 prime?) + +(defun maphash* (f h) + (loop for k being the hash-keys of h + using (hash-value v) + collecting (funcall f k v))) + +(defun hashtable-assoc (h) + (maphash* (lambda (k v) (cons k v)) h)) + +(define-symbol-macro -1?1 (expt -1 (random 2))) + +(defun -1?1 (x) (* -1?1 x)) + +(defun prime? (n) + (and (> n 1) + (or (= 2 n)(oddp n)) + (loop for d upfrom 3 by 2 to (sqrt n) + when (zerop (mod n d)) return nil + finally (return t)))) + ; --- cloucell support for struct access of slots ------------------------ (eval-when (:compile-toplevel :execute :load-toplevel) From ktilton at common-lisp.net Tue Jan 29 20:42:24 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 29 Jan 2008 15:42:24 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080129204224.3420FA0F1@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv3860 Modified Files: trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 04:29:52 1.8 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 20:42:23 1.9 @@ -33,7 +33,7 @@ `(without-c-dependency (call-trc t ,tgt-form , at os)) (let ((tgt (gensym))) - (break "slowww? ~a" tgt-form) + ;(break "slowww? ~a" tgt-form) `(without-c-dependency (bif (,tgt ,tgt-form) (if (trcp ,tgt) From phildebrandt at common-lisp.net Tue Jan 29 23:30:08 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Tue, 29 Jan 2008 18:30:08 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080129233008.146333F03A@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv6741/utils-kt Modified Files: core.lisp detritus.lisp Log Message: make utils-kt work on sbcl. Peter. --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/12/03 20:11:12 1.3 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/29 23:30:06 1.4 @@ -22,7 +22,7 @@ , at body)) (defmacro export! (&rest symbols) - `(eval-when (:compile-toplevel :load-toplevel :execute) + `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) (export ',symbols))) (defmacro define-constant (name value &optional docstring) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/01/29 04:29:55 1.17 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/01/29 23:30:06 1.18 @@ -70,7 +70,7 @@ (export! project-path) (defun project-path () - (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) + #+allegro (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) #+test (test-setup) From phildebrandt at common-lisp.net Wed Jan 30 14:21:01 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 30 Jan 2008 09:21:01 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080130142101.F0D1B5C19C@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv6810 Modified Files: cells-gtk.asd cells3-porting-notes.lisp dialogs.lisp widgets.lisp Log Message: merging in ken's and peter's changes from Jan 29th --- /project/cells/cvsroot/cells-gtk/cells-gtk.asd 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/cells-gtk.asd 2008/01/30 14:21:01 1.2 @@ -8,6 +8,7 @@ ((:file "packages") (:file "conditions") (:file "compat") + (:file "cells3-porting-notes" :depends-on ("packages")) (:file "widgets" :depends-on ("conditions")) (:file "layout" :depends-on ("widgets")) (:file "display" :depends-on ("widgets")) --- /project/cells/cvsroot/cells-gtk/cells3-porting-notes.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/cells3-porting-notes.lisp 2008/01/30 14:21:01 1.2 @@ -20,12 +20,15 @@ (in-package :cells-gtk) -(export '(make-be kids-list?)) (defun make-be (class &rest args) - (md-awaken (apply 'make-instance class args))) + (let ((x (apply 'make-instance class args))) + (md-awaken x) + x)) -(defun to-be (x) (md-awaken x)) +(defun to-be (x) (md-awaken x) x) (defmacro kids-list? (&rest body) - `(c? (the-kids , at body))) \ No newline at end of file + `(c? (the-kids , at body))) + +(export '(make-be to-be kids-list?)) \ No newline at end of file --- /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 14:21:01 1.2 @@ -46,6 +46,7 @@ (message self)))) (defmethod md-awaken :after ((self message-dialog)) + (print 'md-awaken-after) (let ((response (gtk-dialog-run (id self)))) (setf (value self) (case response @@ -54,12 +55,14 @@ (-7 :close) (-8 :yes) (-9 :no)))) - (gtk-widget-destroy (id self)) - (gtk-object-forget (id self) self) (with-slots (content-area) self (when content-area (setf (value self) (value content-area)) - (gtk-object-forget (id content-area) content-area)))) + (print (value content-area)) + (gtk-object-forget (id content-area) content-area))) + (gtk-widget-destroy (id self)) + (gtk-object-forget (id self) self) + (print 'done)) (defun show-message (text &rest inits) (let ((message-widget (to-be (apply #'mk-message-dialog :message text inits)))) --- /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 14:21:01 1.2 @@ -20,7 +20,7 @@ (defmodel gtk-object (family) - ((container :cell nil :initarg :container :accessor container) + ((container :cell nil :initarg :container :accessor container :initform nil) (def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil) (new-function-name :accessor new-function-name :initarg :new-function-name :initform (c? (intern (format nil "GTK-~a-NEW~a" From phildebrandt at common-lisp.net Wed Jan 30 14:21:02 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 30 Jan 2008 09:21:02 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/test-gtk Message-ID: <20080130142102.6C60E5C19C@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv6810/test-gtk Modified Files: test-dialogs.lisp test-gtk.lisp Log Message: merging in ken's and peter's changes from Jan 29th --- /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/30 14:21:02 1.2 @@ -35,16 +35,18 @@ (mk-button :label "Query for text" :on-clicked (callback (w e d) - (let ((dialog - (to-be - (mk-message-dialog - :md-name :rule-name-dialog - :message "Type something:" - :title "My Title" - :message-type :question - :buttons-type :ok-cancel - :content-area (mk-entry :auto-aupdate t))))) - (setf (text (fm^ :message-response)) (value dialog)))))) + (with-integrity (:change 'q4text) + (let ((dialog + (to-be (mk-message-dialog + :md-name :rule-name-dialog + :message "Type something:" + :title "My Title" + :message-type :question + :buttons-type :ok-cancel + :content-area (mk-entry :auto-aupdate t))))) + (print 'back) + (print (list 'value-dialog (value dialog))) + (setf (text (fm^ :message-response)) (value dialog))))))) (loop for message-type in '(:info :warning :question :error) collect (make-kid 'test-message :message-type message-type))))) (mk-label :md-name :message-response) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 14:21:02 1.2 @@ -41,7 +41,7 @@ :kids (c? (the-kids (let ((tabs '("Buttons" "Display" - "Layout" + "Layout" "Menus" "Textview" "Dialogs" @@ -65,7 +65,7 @@ (defun gtk-demo (&optional dbg) - (ukt:test-prep) + #-iamnotkenny (ukt:test-prep) (cells-gtk-init) (cells-gtk:start-app 'test-gtk::test-gtk :debug dbg)) From phildebrandt at common-lisp.net Wed Jan 30 14:33:49 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 30 Jan 2008 09:33:49 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080130143349.68F0074168@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv9106/utils-kt Modified Files: core.lisp Log Message: finally fixed export! for sbcl --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/29 23:30:06 1.4 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/30 14:33:49 1.5 @@ -21,9 +21,11 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) , at body)) -(defmacro export! (&rest symbols) - `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) - (export ',symbols))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro export! (&rest symbols) + `(eval-when ( :compile-toplevel :load-toplevel :execute) + #+sbssscl (export (list ,@(mapcar #'(lambda (x) (list 'quote x)) symbols))) + #-sbclss (export ',symbols)))) (defmacro define-constant (name value &optional docstring) "Define a constant properly. If NAME is unbound, DEFCONSTANT From ktilton at common-lisp.net Wed Jan 30 21:13:44 2008 From: ktilton at common-lisp.net (ktilton) Date: Wed, 30 Jan 2008 16:13:44 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080130211344.B2B1F74161@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv5749 Modified Files: dialogs.lisp gtk-app.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: fixed submenus --- /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 14:21:01 1.2 +++ /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 21:13:44 1.3 @@ -23,27 +23,27 @@ ((message :accessor message :initarg :message :initform nil) (message-type :accessor message-type :initarg :message-type :initform :info) (buttons-type :accessor buttons-type :initarg :buttons-type :initform (c? (if (eql (message-type self) :question) - :yes-no - :close))) + :yes-no + :close))) (content-area :owning t :accessor content-area :initarg :content-area :initform nil)) (markup) () :position :mouse :new-args (c_1 (list +c-null+ - 2 - (ecase (message-type self) - (:info 0) - (:warning 1) - (:question 2) - (:error 3)) - (ecase (buttons-type self) - (:none 0) - (:ok 1) - (:close 2) - (:cancel 3) - (:yes-no 4) - (:ok-cancel 5)) - (message self)))) + 2 + (ecase (message-type self) + (:info 0) + (:warning 1) + (:question 2) + (:error 3)) + (ecase (buttons-type self) + (:none 0) + (:ok 1) + (:close 2) + (:cancel 3) + (:yes-no 4) + (:ok-cancel 5)) + (message self)))) (defmethod md-awaken :after ((self message-dialog)) (print 'md-awaken-after) @@ -55,6 +55,7 @@ (-7 :close) (-8 :yes) (-9 :no)))) + (with-slots (content-area) self (when content-area (setf (value self) (value content-area)) @@ -146,6 +147,8 @@ (if (select-multiple self) (setf (value self) (gtk-file-chooser-get-filenames-strs (id self))) (setf (value self) (gtk-file-chooser-get-filename (id self))))) + (trc "destroying file-chooser-dialog" (id self) self) + (break "ok?") (gtk-widget-destroy (id self)) (gtk-object-forget (id self) self))) --- /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/30 21:13:44 1.2 @@ -83,39 +83,47 @@ (to-be splash) (setf (visible splash) t) (loop while (gtk-events-pending) do - (gtk-main-iteration))) - + (gtk-main-iteration))) + (to-be app) - + (when splash (not-to-be splash) (gtk-window-set-auto-startup-notification t)) (setf (visible app) t) (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) - (unwind-protect - (loop - (restart-case - (handler-bind - ((gtk-user-signals-quit #'give-up-cleanly) - (gtk-continuable-error #'continue-from-error) - (error #'report-error-and-give-up)) - #-lispworks - (gtk-main) - #+lispworks ; give slime a chance. - (loop ; just running your app in a process is not enough. - (loop while (gtk-events-pending) do - (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting"))) - ;; Restart cases - (continue-from-error (c) - (show-message (format nil "Cells-GTK Error: ~a" (text c)) - :message-type :error :title "Cells-GTK Error")) - (give-up-cleanly () (return-from start-app)) - (report-error-and-give-up (c) (error c)))) - ;; clean-up forms (takes down application). - (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? - (loop for i from 0 to 30 do (gtk-main-quit)) - (loop while (gtk-events-pending) do (gtk-main-iteration-do nil))))))) + (unwind-protect + (gtk-main) + #+chill + (loop + (restart-case + (handler-bind + ((gtk-user-signals-quit #'give-up-cleanly) + (gtk-continuable-error #'continue-from-error) + (error #'report-error-and-give-up)) + #-lispworks + (gtk-main) + #+lispworks ; give slime a chance. + (loop ; just running your app in a process is not enough. + (loop while (gtk-events-pending) do + (gtk-main-iteration-do nil)) + (process-wait-with-timeout .01 "GTK event loop waiting"))) + ;; Restart cases + (continue-from-error (c) + (format t "~&Cells-GTK Error: ~a" (text c)) + (show-message (format nil "Cells-GTK Error: ~a" (text c)) + :message-type :error :title "Cells-GTK Error")) + (give-up-cleanly () (return-from start-app)) + (report-error-and-give-up (c) (error c)))) + ;; clean-up forms (takes down application). + (trcx not-to-be-app 42) + (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? + (trcx gtk-main-quits 42) + (loop for i from 0 to 30 do (gtk-main-quit)) + (trcx mopping-events 42) + (loop while (gtk-events-pending) do + (trcx gtk-main-iter-do 42) + (gtk-main-iteration-do nil))))))) ;;; Restarts (defun continue-from-error (c) --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/30 21:13:44 1.2 @@ -184,11 +184,7 @@ () () () :padding 0) -(defobserver .kids ((self menu-shell)) - (when new-value - (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid)))) - #+clisp (call-next-method)) + (def-widget menu-bar (menu-shell) () () ()) @@ -207,10 +203,35 @@ (mk-accel-label :text (label self)))))) (accel :accessor accel :initarg :accel :initform (c-in nil)) (owner :initarg :owner :accessor owner :initform (c-in nil)) - (submenu :cell nil :accessor submenu :initform nil)) ; gtk-menu-item-get-submenu not doing it. POD + (submenu :initarg :submenu :cell nil :accessor submenu :initform nil) ; gtk-menu-item-get-submenu not doing it. POD + (appended? :initarg :appended? :cell nil :accessor appended? :initform nil)) (right-justified) (activate)) +(defobserver .kids ((self menu-shell)) + (when new-value + (dolist (kid new-value) + + (if (appended? kid) + (break "ducking duplicate append of kid ~a to (~a ~a) already in ~a" kid (id self) self (appended? kid)) + (progn + (trc nil "mshell" (id self) self :kid kid :kidid (id kid) :kidpar (fm-parent kid)) + (gtk-menu-shell-append (id self) (id kid)) + (setf (appended? kid) (cons (id self) self)))))) + #+clisp (call-next-method)) + +(defobserver .kids ((self menu-item)) + (when old-value ; pod never occurs ? + (gtk-menu-item-remove-submenu (id self))) + (when new-value + (with-integrity (:change 'set-sub-menu-actually) + (unless (submenu self) + (let ((subid (id (setf (submenu self) + (make-instance 'menu + :md-name (gensym "SUBMENU-MENU") + :kids new-value))))) ;; <=== was mak + (gtk-menu-item-set-submenu (id self) subid)))))) + (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel (let ((mods 0)) @@ -237,13 +258,10 @@ (gtk-accel-label-set-accel-widget (id new-value) (id self)) (gtk-container-add (id self) (id new-value)))) -(defobserver .kids ((self menu-item)) - (when old-value ; pod never occurs ? - (gtk-menu-item-remove-submenu (id self))) - (when new-value - (with-integrity (:change 'set-sub-menu-actually) - (gtk-menu-item-set-submenu (id self) - (id (setf (submenu self) (make-be 'menu :kids new-value))))))) + + +;;;if the make-be is a make-instance we do not crash, but we get an empty submenu (or +;;;is it just disabled?). (def-widget check-menu-item (menu-item) ((init :accessor init :initarg :init :initform nil)) --- /project/cells/cvsroot/cells-gtk/tree-view.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/tree-view.lisp 2008/01/30 21:13:44 1.2 @@ -35,7 +35,7 @@ () :new-args (c_1 (list (item-types self)))) -(defun fail (&rest args) (declare (ignore args))) +(defun tv-fail (&rest args) (declare (ignore args))) (def-widget tree-view () ((columns-def :accessor columns-def :initarg :columns :initform nil) @@ -52,7 +52,7 @@ :container self col-init)) (column-inits self)))) - (select-if :unchanged-if #'fail + (select-if :unchanged-if #'tv-fail :accessor select-if :initarg :select-if :initform (c-in nil)) (roots :accessor roots :initarg :roots :initform nil) (print-fn :accessor print-fn :initarg :print-fn :initform #'identity) --- /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 14:21:01 1.2 +++ /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 21:13:44 1.3 @@ -310,7 +310,8 @@ (defmethod not-to-be :after ((self widget)) (when t ; *gtk-debug* - (trc "WIDGET DESTROY" (md-name self) self) (force-output)) + (trc nil "WIDGET DESTROY" (md-name self) (type-of self) self) + (force-output)) (gtk-object-forget (slot-value self 'id) self) (gtk-widget-destroy (slot-value self 'id))) From ktilton at common-lisp.net Wed Jan 30 21:13:45 2008 From: ktilton at common-lisp.net (ktilton) Date: Wed, 30 Jan 2008 16:13:45 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/test-gtk Message-ID: <20080130211345.081A770C8@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv5749/test-gtk Modified Files: test-buttons.lisp test-dialogs.lisp test-gtk.lisp test-menus.lisp Log Message: fixed submenus --- /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/30 21:13:44 1.2 @@ -26,6 +26,7 @@ (incf (nclics (upper self test-buttons))))) (mk-button :label "Continuable error" :on-clicked (callback (widget event data) + (trc "issuing continuable error" widget event) (error 'gtk-continuable-error :text "Oops!"))) (mk-toggle-button :md-name :toggled-button :markup (c? (with-markup (:foreground (if (value self) :red :blue)) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/30 14:21:02 1.2 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/30 21:13:44 1.3 @@ -28,6 +28,7 @@ :kids (kids-list? (mk-hbox :kids (kids-list? + (append #-libcellsgtk nil #+libcellsgtk @@ -36,19 +37,20 @@ :on-clicked (callback (w e d) (with-integrity (:change 'q4text) - (let ((dialog - (to-be (mk-message-dialog - :md-name :rule-name-dialog - :message "Type something:" - :title "My Title" - :message-type :question - :buttons-type :ok-cancel - :content-area (mk-entry :auto-aupdate t))))) - (print 'back) - (print (list 'value-dialog (value dialog))) - (setf (text (fm^ :message-response)) (value dialog))))))) + (let ((dialog + (to-be (mk-message-dialog + :md-name :rule-name-dialog + :message "Type something:" + :title "My Title" + :message-type :question + :buttons-type :ok-cancel + :content-area (mk-entry :auto-aupdate t))))) + (print 'back) + (print (list 'value-dialog (value dialog))) + (setf (text (fm^ :message-response)) (value dialog))))))) (loop for message-type in '(:info :warning :question :error) collect (make-kid 'test-message :message-type message-type))))) + (mk-label :md-name :message-response) (mk-hbox :kids (kids-list? @@ -62,12 +64,12 @@ :tab-labels (list "Open" "Save" "Select folder" "Create folder") :kids (kids-list? (loop for action in '(:open :save :select-folder :create-folder) collect - (mk-vbox - :kids (kids-list? - (mk-file-chooser-widget :md-name action - :action action - :expand t :fill t - :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) - :select-multiple (c? (value (fm^ :multiple)))) - (mk-check-button :label "Select multiple" :md-name :multiple) - (mk-label :text (c? (format nil "~a ~a" (md-name (psib (psib))) (value (psib (psib)))))))))))))) + (mk-vbox + :kids (kids-list? + (mk-file-chooser-widget :md-name action + :action action + :expand t :fill t + :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) + :select-multiple (c? (value (fm^ :multiple)))) + (mk-check-button :label "Select multiple" :md-name :multiple) + (mk-label :text (c? (format nil "~a ~a" (md-name (psib (psib))) (value (psib (psib)))))))))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 14:21:02 1.2 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 21:13:44 1.3 @@ -39,15 +39,16 @@ :splash-screen-image (namestring *splash-image*) :width 650 :height 550 :kids (c? (the-kids - (let ((tabs '("Buttons" - "Display" - "Layout" + (let ((tabs '(;"Buttons" + ;"Display" + ;"Layout" + "Menus" - "Textview" - "Dialogs" - "Addon" - "Entry" - "Tree-view" + ;"Textview" + ;"Dialogs" + ;"Addon" + ;"Entry" + ;"Tree-view" ))) (list (mk-notebook :tab-labels tabs @@ -65,7 +66,10 @@ (defun gtk-demo (&optional dbg) - #-iamnotkenny (ukt:test-prep) + #-iamnotkenny + (PROGN + (dribble "/cells-gtk/demo.log") + (ukt:test-prep)) (cells-gtk-init) (cells-gtk:start-app 'test-gtk::test-gtk :debug dbg)) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/30 21:13:44 1.2 @@ -7,6 +7,7 @@ (mk-menu-bar :kids (kids-list? (mk-menu-item + :md-name 'menu-1 :label "Menu 1" :kids (kids-list? (mk-image-menu-item @@ -14,28 +15,41 @@ :accel '(#\s :control :shift :alt) :image (mk-image :stock :save :icon-size :menu) :on-activate (callback (widget event data) - (trc nil "TST") (force-output))) + (trc "TST SAVE") (force-output))) (mk-menu-item + :md-name (gensym "SUBMENU-MENUITEM") :label "Submenu" :kids (kids-list? - (mk-menu-item :label "subitem1") - (mk-menu-item :label "subitem2") - (mk-menu-item :label "subitem3"))) + (mk-menu-item + :md-name (gensym "SUBITEM-1") + :label "subitem1" + :on-activate (callback (widget event data) + (trc "dribble SAVE") (dribble))) + (mk-menu-item + :md-name (gensym "SUBITEM-2") + :label "subitem2") + (mk-menu-item :label "subitem3") + )) (mk-image-menu-item :stock :harddisk :on-activate (callback (widget event data) - (trc nil "HARDDISK") (force-output))) + (trc "HARDDISK" widget event data) + (force-output))) (mk-image-menu-item :image (mk-image :stock :dialog-info :icon-size :menu) :label-widget (mk-label :markup (with-markup (:foreground :blue) "Blue label"))) (mk-image-menu-item :stock :my-g - :label "user stock icon"))) + :label "user stock icon") + )) (mk-menu-item + :md-name 'menu-2 :label "Menu 2" :visible (c? (value (fm^ :menu2-visible))) - :sensitive (c? (value (fm^ :menu2-sensitive))) + :sensitive (c? (let ((x (fm^ :menu2-sensitive))) + (trc "located m2sensi" x) + (value x))) :kids (kids-list? (mk-tearoff-menu-item) (mk-check-menu-item @@ -47,7 +61,8 @@ (mk-check-menu-item :label "Sub-option 2" :md-name :sub-option2 - :init t))) + :init t)) + ) (mk-menu-item :label "Menu 3" :md-name :menu3 @@ -144,7 +159,7 @@ '("DD/MM/YY" "DD/MM/YYYY" "MM/DD/YY" "YYYY-MM-DD" "YYYY-MM-DDTHH:MM:SS" "DD/MM/YY HH:MM:SS"))))))) (mk-hseparator :padding 5) - (mk-hbox + (mk-hbox :kids (kids-list? (mk-event-box :popup (mk-menu From ktilton at common-lisp.net Thu Jan 31 03:30:18 2008 From: ktilton at common-lisp.net (ktilton) Date: Wed, 30 Jan 2008 22:30:18 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080131033018.5FAA27E011@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv20671 Modified Files: cell-types.lisp initialize.lisp md-slot-value.lisp model-object.lisp propagate.lisp Log Message: Fixed a whole in initialization such that a slot could be observed twice, unhealthy when observers have side effects. --- /project/cells/cvsroot/cells/cell-types.lisp 2008/01/29 04:29:52 1.28 +++ /project/cells/cvsroot/cells/cell-types.lisp 2008/01/31 03:30:17 1.29 @@ -37,6 +37,7 @@ ; a dependency on the existence of instance owning X (pulse 0 :type fixnum) (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP + (pulse-observed 0 :type fixnum) lazy (optimize t) debug --- /project/cells/cvsroot/cells/initialize.lisp 2006/06/23 01:04:56 1.8 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/01/31 03:30:17 1.9 @@ -32,8 +32,11 @@ ; ; nothing to calculate, but every cellular slot should be output ; - (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) - (ephemeral-reset c)) + (trc nil "awaken cell observing" c) + (when (> *data-pulse-id* (c-pulse-observed c)) + (setf (c-pulse-observed c) *data-pulse-id*) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) + (ephemeral-reset c))) (defmethod awaken-cell ((c c-ruled)) (let (*call-stack*) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/29 04:29:52 1.37 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/31 03:30:17 1.38 @@ -328,7 +328,7 @@ ) ;; (when (trcp c) (break "go optimizing ~a" c)) - #+shh (when (trcp c) + (when (trcp c) (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c)))) ) --- /project/cells/cvsroot/cells/model-object.lisp 2008/01/29 04:29:52 1.17 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/01/31 03:30:17 1.18 @@ -104,7 +104,8 @@ (defmethod md-awaken :around ((self model-object)) (when (eql :nascent (md-state self)) - (call-next-method))) + (call-next-method)) + self) #+test (md-slot-cell-type 'cgtk::label 'cgtk::container) @@ -150,7 +151,12 @@ ;; but first I worried about it being slow keeping the flushed list /and/ searching, then ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)) + (let ((flushed (md-slot-cell-flushed self slot-name))) + (when (or (null flushed) ;; constant, ie, never any cell provided for this slot + (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely + (when flushed + (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))) ((find (c-lazy c) '(:until-asked :always t)) @@ -179,6 +185,11 @@ (cdr (assoc slot-name (cells self))) (get slot-name 'cell))) +(defmethod md-slot-cell-flushed (self slot-name) + (if self + (cdr (assoc slot-name (cells-flushed self))) + (get slot-name 'cell))) + #+test (get 'cgtk::label :cell-types) --- /project/cells/cvsroot/cells/propagate.lisp 2007/11/30 16:51:18 1.28 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/01/31 03:30:17 1.29 @@ -113,8 +113,14 @@ (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c)) - (slot-value-observe (c-slot-name c) (c-model c) - (c-value c) prior-value prior-value-supplied) + (trc nil "c-propagate observing" c) + + ; this next assertion is just to see if we can ever come this way twice. If so, just + ; make it a condition on whether to observe + (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c)) + (setf (c-pulse-observed c) *data-pulse-id*) + (slot-value-observe (c-slot-name c) (c-model c) + (c-value c) prior-value prior-value-supplied)) ; From ktilton at common-lisp.net Thu Jan 31 03:31:12 2008 From: ktilton at common-lisp.net (ktilton) Date: Wed, 30 Jan 2008 22:31:12 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080131033112.03538490A8@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv20829 Modified Files: gtk-app.lisp menus.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/30 21:13:44 1.2 +++ /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/31 03:31:12 1.3 @@ -62,7 +62,6 @@ (defvar *gtk-initialized* nil) - (defun start-app (app-name &key debug) (let ((*gtk-debug* debug)) (when (not *gtk-initialized*) @@ -93,8 +92,6 @@ (setf (visible app) t) (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) (unwind-protect - (gtk-main) - #+chill (loop (restart-case (handler-bind @@ -116,13 +113,10 @@ (give-up-cleanly () (return-from start-app)) (report-error-and-give-up (c) (error c)))) ;; clean-up forms (takes down application). - (trcx not-to-be-app 42) + (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? - (trcx gtk-main-quits 42) (loop for i from 0 to 30 do (gtk-main-quit)) - (trcx mopping-events 42) (loop while (gtk-events-pending) do - (trcx gtk-main-iter-do 42) (gtk-main-iteration-do nil))))))) ;;; Restarts --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/30 21:13:44 1.2 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/31 03:31:12 1.3 @@ -224,13 +224,14 @@ (when old-value ; pod never occurs ? (gtk-menu-item-remove-submenu (id self))) (when new-value - (with-integrity (:change 'set-sub-menu-actually) - (unless (submenu self) - (let ((subid (id (setf (submenu self) - (make-instance 'menu - :md-name (gensym "SUBMENU-MENU") - :kids new-value))))) ;; <=== was mak - (gtk-menu-item-set-submenu (id self) subid)))))) + #+chill (when (eq (md-name self) 'test-gtk::SUBMENU-MENUITEM) + (break "NN obs kids enqueues submenu ~a" self cells::*data-pulse-id*)) + (with-integrity (:awaken 'set-sub-menu-actually) + (let ((subid (id (setf (submenu self) + (make-instance 'menu + :md-name (gensym "SUBMENU-MENU") + :kids new-value))))) ;; <=== was mak + (gtk-menu-item-set-submenu (id self) subid))))) (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel From ktilton at common-lisp.net Thu Jan 31 03:31:13 2008 From: ktilton at common-lisp.net (ktilton) Date: Wed, 30 Jan 2008 22:31:13 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk/test-gtk Message-ID: <20080131033113.99FFC4B023@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv20829/test-gtk Modified Files: test-gtk.lisp test-menus.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 21:13:44 1.3 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/31 03:31:13 1.4 @@ -39,16 +39,16 @@ :splash-screen-image (namestring *splash-image*) :width 650 :height 550 :kids (c? (the-kids - (let ((tabs '(;"Buttons" - ;"Display" - ;"Layout" + (let ((tabs '("Buttons" + "Display" + "Layout" "Menus" - ;"Textview" - ;"Dialogs" - ;"Addon" - ;"Entry" - ;"Tree-view" + "Textview" + "Dialogs" + "Addon" + "Entry" + "Tree-view" ))) (list (mk-notebook :tab-labels tabs --- /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/30 21:13:44 1.2 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/31 03:31:13 1.3 @@ -17,19 +17,19 @@ :on-activate (callback (widget event data) (trc "TST SAVE") (force-output))) (mk-menu-item - :md-name (gensym "SUBMENU-MENUITEM") + :md-name 'SUBMENU-MENUITEM :label "Submenu" - :kids (kids-list? - (mk-menu-item - :md-name (gensym "SUBITEM-1") - :label "subitem1" - :on-activate (callback (widget event data) - (trc "dribble SAVE") (dribble))) - (mk-menu-item - :md-name (gensym "SUBITEM-2") + :kids (c? (the-kids + (mk-menu-item + :md-name (gensym "SUBITEM-1") + :label "subitem1" + :on-activate (callback (widget event data) + (trc "dribble SAVE") (dribble))) + (mk-menu-item + :md-name (gensym "SUBITEM-2") :label "subitem2") - (mk-menu-item :label "subitem3") - )) + (mk-menu-item :label "subitem3") + ))) (mk-image-menu-item :stock :harddisk :on-activate (callback (widget event data) From ktilton at common-lisp.net Thu Jan 31 06:50:26 2008 From: ktilton at common-lisp.net (ktilton) Date: Thu, 31 Jan 2008 01:50:26 -0500 (EST) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080131065026.89F811206E@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv1150 Modified Files: menus.lisp textview.lisp Log Message: de-closify the menu used to implement submenus --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/31 03:31:12 1.3 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/31 06:50:25 1.4 @@ -185,7 +185,6 @@ :padding 0) - (def-widget menu-bar (menu-shell) () () ()) @@ -203,35 +202,24 @@ (mk-accel-label :text (label self)))))) (accel :accessor accel :initarg :accel :initform (c-in nil)) (owner :initarg :owner :accessor owner :initform (c-in nil)) - (submenu :initarg :submenu :cell nil :accessor submenu :initform nil) ; gtk-menu-item-get-submenu not doing it. POD - (appended? :initarg :appended? :cell nil :accessor appended? :initform nil)) + (submenu-id :initarg :submenu-id :cell nil :accessor submenu-id :initform nil) ; gtk-menu-item-get-submenu not doing it. POD + ) (right-justified) (activate)) (defobserver .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - - (if (appended? kid) - (break "ducking duplicate append of kid ~a to (~a ~a) already in ~a" kid (id self) self (appended? kid)) - (progn - (trc nil "mshell" (id self) self :kid kid :kidid (id kid) :kidpar (fm-parent kid)) - (gtk-menu-shell-append (id self) (id kid)) - (setf (appended? kid) (cons (id self) self)))))) + (gtk-menu-shell-append (id self) (id kid)))) #+clisp (call-next-method)) (defobserver .kids ((self menu-item)) (when old-value ; pod never occurs ? - (gtk-menu-item-remove-submenu (id self))) + (gtk-menu-item-remove-submenu (id self))) ;; almost certainly wrong -- better to Just Break here? (when new-value - #+chill (when (eq (md-name self) 'test-gtk::SUBMENU-MENUITEM) - (break "NN obs kids enqueues submenu ~a" self cells::*data-pulse-id*)) - (with-integrity (:awaken 'set-sub-menu-actually) - (let ((subid (id (setf (submenu self) - (make-instance 'menu - :md-name (gensym "SUBMENU-MENU") - :kids new-value))))) ;; <=== was mak - (gtk-menu-item-set-submenu (id self) subid))))) + (gtk-menu-item-set-submenu (id self) (setf (submenu-id self) (gtk-menu-new))) + (dolist (kid new-value) + (gtk-menu-shell-append (submenu-id self) (id kid))))) (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel --- /project/cells/cvsroot/cells-gtk/textview.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/textview.lisp 2008/01/31 06:50:25 1.2 @@ -94,8 +94,6 @@ item))) #'(lambda (popup-menu) (loop for old in (old-popups text-view) do - (when-bind (sub (submenu old)) - (gtk-object-forget (id sub) sub)) (gtk-object-forget (id old) old)) (let ((tops (mapcar #'do-padds p-adds))) (setf (old-popups text-view) accum)