- cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS cells
by ktilton 29 Jan '08

29 Jan '08

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 ,@os)) (let ((tgt (gensym))) - (break "slowww? ~a" tgt-form) + ;(break "slowww? ~a" tgt-form) `(without-c-dependency (bif (,tgt ,tgt-form) (if (trcp ,tgt)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 29 Jan '08

29 Jan '08

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 ,@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)

1 0

[cells-cvs] CVS cells
by ktilton 29 Jan '08

29 Jan '08

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 ,@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 ,@initargs)) + `(make-part ',md-name ',md-class ,@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 ,@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))))))

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 29 Jan '08

29 Jan '08

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

1 0

[cells-cvs] CVS cells-gtk/test-gtk
by ktilton 29 Jan '08

29 Jan '08

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]

1 0

[cells-cvs] CVS cells-gtk/root
by ktilton 29 Jan '08

29 Jan '08

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.… ...and follow the INSTALL.TXT in that. ############################################################################################################## Dependencies: Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.… Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.ta… Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz… On windows install Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zi… 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 ;;; <cclan-list(a)lists.sf.net>. But note first that the canonical ;;; source for asdf is presently the cCLan CVS repository at ;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/> ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting ;;; bugs. There are usually two "supported" revisions - the CVS HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; the problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous #:hyperdocumentation #:hyperdoc #:compile-op #:load-op #:load-source-op #:test-system-version #:test-op #:operation ; operations #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:input-files #:output-files #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file #:static-file #:doc-file #:html-file #:text-file #:source-file-type #:module ; components #:system #:unix-dso #:module-components ; component accessors #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-property #:component-system #:component-depends-on #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:operation-on-warnings #:operation-on-failure ;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors #:retry #:accept ; restarts ) (:use :cl)) #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) (defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot (list (parse-integer v :start (1+ colon) :junk-allowed t) (parse-integer v :start (1+ dot) :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (defun pathname-sans-name+type (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) (define-modify-macro appendf (&rest args) append "Append onto list") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function ;; over print-object; this is always conditions::%print-condition for ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply #'format s (format-control c) (format-arguments c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) (format s "~@<erred while invoking ~A on ~A~@:>" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to) ;;; XXX crap name (do-first :initform nil :initarg :do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated (inline-methods :accessor component-inline-methods :initform nil) (parent :initarg :parent :initform nil :reader component-parent) ;; no direct accessor for pathname, we do this as a method to allow ;; 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 "~@<component ~S not found~ ~@[ or does not match version ~A~]~ ~@[ in ~A~]~@:>" (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 "~@<invalid component designator ~A~@:>" 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]

1 0

[cells-cvs] CVS cells-gtk/pod-utils
by ktilton 28 Jan '08

28 Jan '08

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 ,@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 ,@os)) (let ((tgt (gensym))) `(,wrapper (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn (assert (stringp ,(car os))) (call-trc t ,@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 <fn> :key <key> :test <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 ,@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 "~%"))) ,@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]

1 0

[cells-cvs] CVS cells-gtk/gtk-ffi
by ktilton 28 Jan '08

28 Jan '08

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 <gdk/gdkcairo.h> #include <gdk/gdkcolor.h> #include <gdk/gdkcursor.h> #include <gdk/gdkdisplay.h> #include <gdk/gdkdnd.h> #include <gdk/gdkdrawable.h> #include <gdk/gdkenumtypes.h> #include <gdk/gdkevents.h> #include <gdk/gdkfont.h> #include <gdk/gdkgc.h> #include <gdk/gdkimage.h> #include <gdk/gdkinput.h> #include <gdk/gdkkeys.h> #include <gdk/gdkdisplaymanager.h> #include <gdk/gdkpango.h> #include <gdk/gdkpixbuf.h> #include <gdk/gdkpixmap.h> #include <gdk/gdkproperty.h> #include <gdk/gdkregion.h> #include <gdk/gdkrgb.h> #include <gdk/gdkscreen.h> #include <gdk/gdkselection.h> #include <gdk/gdkspawn.h> #include <gdk/gdktypes.h> #include <gdk/gdkvisual.h> #include <gdk/gdkwindow.h> 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]

1 0

[cells-cvs] CVS cells-gtk/cffi/uffi-compat
by ktilton 28 Jan '08

28 Jan '08

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 <jamesjb(a)jamesjb.com> ;;; ;;; 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)) ,@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) ,@body)) `(progn ,@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)) ,@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))) ,@body) (cffi:with-foreign-string (,foreign-string ,str) ,@body))))) ;; Taken from UFFI's src/strings.lisp (defmacro with-cstrings (bindings &rest body) (if bindings `(with-cstring ,(car bindings) (with-cstrings ,(cdr bindings) ,@body)) [224 lines skipped]

1 0

[cells-cvs] CVS cells-gtk/cffi/tests
by ktilton 28 Jan '08

28 Jan '08

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 <jamesjb(a)jamesjb.com> # # 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 <loliveira((a))common-lisp.net> ;;; ;;; 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 <loliveira((a))common-lisp.net> ;;; ;;; 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]

1 0