[snow-cvs] r15 - in trunk/src: java/snow/example lisp/snow lisp/snow/swing
Alessio Stalla
astalla at common-lisp.net
Thu Nov 12 22:22:30 UTC 2009
Author: astalla
Date: Thu Nov 12 17:22:30 2009
New Revision: 15
Log:
Rationalized compilation and packages
Added fix-implementation (untested)
Modified:
trunk/src/java/snow/example/example.lisp
trunk/src/lisp/snow/compile-system.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/swing/swing.lisp
trunk/src/lisp/snow/utils.lisp
Modified: trunk/src/java/snow/example/example.lisp
==============================================================================
--- trunk/src/java/snow/example/example.lisp (original)
+++ trunk/src/java/snow/example/example.lisp Thu Nov 12 17:22:30 2009
@@ -11,12 +11,6 @@
(with-gui (:swing)
(frame (:id frame :title "Sample JFrame" :visible-p t)
- (tree :model (make-tree-model '(1 2 (c (a b)) 3)))
- (button :text "push me"
- :on-action (lambda (event)
- (princ "Thanks for pushing me! ")
- (format t "My parent is ~A~%" frame)
- (finish-output)))
(scroll (:layout "grow")
(list-widget :model (make-list-model '(1 2 (c (a b)) 3))
:prototype-cell-value "abcdefghijklmnopq"))
@@ -57,6 +51,13 @@
"Nested property")
(setf (var *variable*) "Test var")
(setf (aaa *cells-object*) "Test cell")))))
+ (panel ()
+ (tree :model (make-tree-model '(1 2 (c (a b)) 3)))
+ (button :text "push me"
+ :on-action (lambda (event)
+ (princ "Thanks for pushing me! ")
+ (format t "My parent is ~A~%" frame)
+ (finish-output))))
(pack frame)))
(let ((fr (frame (:title "pippo" :visible-p t)
Modified: trunk/src/lisp/snow/compile-system.lisp
==============================================================================
--- trunk/src/lisp/snow/compile-system.lisp (original)
+++ trunk/src/lisp/snow/compile-system.lisp Thu Nov 12 17:22:30 2009
@@ -1,15 +1,12 @@
(require :asdf)
-(unwind-protect
- (unless
- (progn
- (jstatic "initAux" "snow.Snow")
- (format t "asdf:*central-registry*: ~S" asdf:*central-registry*)
- (pushnew :snow-cells *features*)
- (format t "compiling snow...")
- (asdf:oos 'asdf:compile-op :snow)
- (format t "success~%")
- t)
- (format t "failed~%"))
- (terpri)
+(jstatic "initAux" "snow.Snow")
+(pushnew :snow-cells *features*)
+(format t "Compiling snow...~%")
+(handler-bind ((error
+ #'(lambda (c)
+ (format t "Compilation failed: ~A~%" c)
+ (quit :status 1))))
+ (asdf:oos 'asdf:compile-op :snow)
+ (format t "Success!~%")
(quit))
\ No newline at end of file
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Thu Nov 12 17:22:30 2009
@@ -46,12 +46,21 @@
;;Models
#:make-list-model
#:make-tree-model
+ ;;Event Listeners
+ #:make-action-listener
;;Common operations on widgets
#:add-child
+ #:dispose
#:dont-add
#:hide
#:pack
+ #:scroll-panel-view
+ #:set-widget-properties
#:show
+ #:widget-enabled-p
+ #:widget-location
+ #:widget-property
+ #:widget-size
;;Data binding
#:make-var
#:make-bean-data-binding
@@ -63,6 +72,14 @@
#:cell
#:slot
;;Various
+ #:call-in-gui-thread
+ #:defimplementation
+ #:definterface
+ #:*gui-backend*
+ #:jbool
+ #:layout-manager
+ #:make-dialog-prompt-stream
+ #:make-layout-manager
#:install-graphical-debugger
#:*parent*
#:self
@@ -74,4 +91,5 @@
#:new))
(defpackage :snow-user
- (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells))
\ No newline at end of file
+ (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)
+ (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
\ No newline at end of file
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Thu Nov 12 17:22:30 2009
@@ -46,8 +46,10 @@
(princ (char-downcase ch) out))))
str))))
-(defgeneric widget-property (widget name))
-(defgeneric (setf widget-property) (value widget name))
+(defgeneric widget-property (widget name)
+ (:documentation "Retrieves the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries."))
+(defgeneric (setf widget-property) (value widget name)
+ (:documentation "Sets the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries."))
(defmethod (setf widget-property) (value widget name)
(setf (jproperty-value widget (dashed->camelcased name))
@@ -76,12 +78,15 @@
`(setf (widget-property ,widget-var ,key) ,value))
props))))
-(defgeneric bind-widget (widget binding))
+(defgeneric bind-widget (widget binding)
+ (:documentation "Connects a widget to a data binding. The framework automatically chooses which property of the widget to connect."))
(definterface make-layout-manager *gui-backend* (widget type &rest args))
+(definterface (setf layout-manager) *gui-backend* (lm widget))
+
(defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys)
- (setf (widget-property self :layout);;Swing specific!!
+ (setf (layout-manager self)
(apply #'make-layout-manager self (ensure-list layout-manager))))
(defun generate-default-children-processing-code (id children)
@@ -213,7 +218,7 @@
, at body))))))
;;Common Interfaces
-(defvar *gui-backend* :swing)
+(defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.")
(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 12 17:22:30 2009
@@ -28,7 +28,11 @@
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
-(in-package :snow)
+(defpackage :snow-swing
+ (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)
+ (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
+
+(in-package :snow-swing)
(defmacro defimpl (name args &body body)
`(defimplementation ,name (*gui-backend* :swing) ,args
@@ -59,11 +63,14 @@
(:border (new "java.awt.BorderLayout"))
((nil) nil))))
+(defimpl (setf layout-manager) (lm widget)
+ (setf (widget-property widget :layout) lm))
+
(defconstant +add-to-container+ (jmethod "java.awt.Container" "add" "java.awt.Component"))
(defconstant +add-to-container-with-constraints+ (jmethod "java.awt.Container" "add" "java.lang.String" "java.awt.Component"))
-(defimplementation call-in-gui-thread (*gui-backend* :swing) (fn)
+(defimpl call-in-gui-thread (fn)
(jstatic "invokeLater" "javax.swing.SwingUtilities"
(new "snow.FunctionRunnable" fn)))
@@ -102,7 +109,7 @@
;;; --- Widgets --- ;;;
;Frames and dialogs
-(defimplementation make-frame (*gui-backend* :swing)
+(defimplementation snow::make-frame (*gui-backend* :swing)
(&key title visible-p on-close &allow-other-keys)
(let ((f (new "javax.swing.JFrame")))
(set-widget-properties f
@@ -120,7 +127,7 @@
nil nil on-close nil nil nil nil))))
f))
-(defimplementation make-dialog (*gui-backend* :swing)
+(defimplementation snow::make-dialog (*gui-backend* :swing)
(&key parent title modal-p visible-p &allow-other-keys)
(let ((d (new "javax.swing.JDialog"
parent
@@ -137,10 +144,10 @@
window)
;Panels
-(defimplementation make-panel (*gui-backend* :swing) (&key &allow-other-keys)
+(defimpl snow::make-panel (&key &allow-other-keys)
(new "javax.swing.JPanel"))
-(defimplementation make-tabs (*gui-backend* :swing)
+(defimplementation snow::make-tabs (*gui-backend* :swing)
(&key (wrap t) (tab-placement :top) &allow-other-keys)
(let ((tabs (new "javax.swing.JTabbedPane")))
(invoke "setTabLayoutPolicy" tabs
@@ -155,19 +162,19 @@
(:right (jfield "javax.swing.JTabbedPane" "RIGHT"))))
tabs))
-(defimplementation make-scroll-panel (*gui-backend* :swing) (view)
+(defimplementation snow::make-scroll-panel (*gui-backend* :swing) (view)
(let ((p (new "javax.swing.JScrollPane")))
(setf (scroll-panel-view p) view)
p))
-(defimplementation scroll-panel-view (*gui-backend* :swing) (self)
+(defimplementation snow::scroll-panel-view (*gui-backend* :swing) (self)
(jproperty-value self "viewportView"))
-(defimplementation (setf scroll-panel-view) (*gui-backend* :swing) (view self)
+(defimpl (setf snow::scroll-panel-view) (view self)
(setf (jproperty-value self "viewportView") view))
;Buttons
-(defimplementation make-button (*gui-backend* :swing)
+(defimplementation snow::make-button (*gui-backend* :swing)
(&key text on-action &allow-other-keys)
(let ((btn (new "javax.swing.JButton")))
(when text
@@ -178,7 +185,7 @@
(make-action-listener on-action)))
btn))
-(defimpl make-check-box (&key text selected-p &allow-other-keys)
+(defimpl snow::make-check-box (&key text selected-p &allow-other-keys)
(let ((btn (new "javax.swing.JCheckBox")))
(when text
(setf (widget-property btn :text) text))
@@ -187,38 +194,34 @@
btn))
;Text
-(defimplementation make-label (*gui-backend* :swing)
- (&key text &allow-other-keys)
+(defimpl snow::make-label (&key text &allow-other-keys)
(let ((lbl (new "javax.swing.JLabel")))
(when text
(setf (widget-property lbl :text) text))
lbl))
-(defimplementation make-text-field (*gui-backend* :swing)
- (&key text &allow-other-keys)
+(defimpl snow::make-text-field (&key text &allow-other-keys)
(let ((field (new "javax.swing.JTextField")))
(when text
(setf (widget-property field :text) text))
field))
-(defimplementation make-text-area (*gui-backend* :swing)
- (&key text &allow-other-keys)
+(defimpl snow::make-text-area (&key text &allow-other-keys)
(let ((text-area (new "javax.swing.JTextArea")))
(when text
(setf (widget-property text-area :text) text))
text-area))
-(defun make-dialog-prompt-stream ()
+(defun snow::make-dialog-prompt-stream () ;;todo!!
(new "snow.SwingDialogPromptStream"))
;;Lists
(defun make-list-model (list)
(new "snow.list.ConsListModel" list))
-(defimplementation make-list-widget (*gui-backend* :swing)
- (&key model prototype-cell-value selected-index
- (cell-renderer (new "snow.list.ConsListCellRenderer"))
- &allow-other-keys)
+(defimpl snow::make-list-widget (&key model prototype-cell-value selected-index
+ (cell-renderer (new "snow.list.ConsListCellRenderer"))
+ &allow-other-keys)
(let ((list (new "javax.swing.JList")))
(when model (setf (widget-property list :model) model))
(setf (widget-property list :cell-renderer)
@@ -232,18 +235,15 @@
(defun make-tree-model (list)
(new "snow.tree.ConsTreeModel" list))
-(defimplementation make-tree-widget (*gui-backend* :swing)
- (&key model
- (cell-renderer (new "snow.tree.ConsTreeCellRenderer"))
- &allow-other-keys)
+(defimpl snow::make-tree-widget (&key model (cell-renderer (new "snow.tree.ConsTreeCellRenderer"))
+ &allow-other-keys)
(let ((tree (new "javax.swing.JTree")))
(when model (setf (widget-property tree :model) model))
(setf (widget-property tree :cell-renderer) cell-renderer)
tree))
;;REPL
-(defimplementation make-gui-repl (*gui-backend* :swing)
- (&key dispose-on-close environment)
+(defimpl snow::make-gui-repl (&key dispose-on-close environment)
(let ((text-area (new "javax.swing.JTextArea"))
(repl-doc (new "snow.swing.ConsoleDocument"
(compile nil
@@ -258,5 +258,5 @@
(invoke "disposeOnClose" repl-doc dispose-on-close))
text-area))
-(defimplementation dispose-gui-repl (*gui-backend* :swing) (repl)
+(defimpl snow::dispose-gui-repl (repl)
(invoke "dispose" (widget-property repl :document)))
Modified: trunk/src/lisp/snow/utils.lisp
==============================================================================
--- trunk/src/lisp/snow/utils.lisp (original)
+++ trunk/src/lisp/snow/utils.lisp Thu Nov 12 17:22:30 2009
@@ -116,7 +116,7 @@
`(progn
(defun ,name (&rest ,args) ;todo...
,@(when documentation `(,documentation))
- (destructuring-bind ,arglist ,args
+ (destructuring-bind ,arglist ,args ;to check for arglist consistency
(declare (ignore ,@(extract-argument-names arglist))))
(let ((impl (get-implementation ',dispatch-var ',name ,dispatch-var)))
(if impl
@@ -131,6 +131,14 @@
`(setf (get-implementation ',dispatch-var ',name ,dispatch-value)
(lambda ,arglist , at body))) ;todo check arglist is congruent with interface
+(defun fix-implementation (dispatch-var)
+ "Makes the current implementation of an interface permanent, avoiding a layer of indirection when calling the interface functions and thus improving performance, but losing the ability to change the implementation at runtime. Use only when your are absolutely sure you won't ever need to use a different implementation."
+ (let ((dispatch-value (eval dispatch-var)))
+ (loop
+ :for entry :in (get-interfaces dispatch-var)
+ :do (setf (symbol-function (car entry))
+ (interface-implementation (cdr entry) dispatch-value)))))
+
;;BROKEN
(defmacro with-implementation ((dispatch-var
&optional (dispatch-value (eval dispatch-var)))
More information about the snow-cvs
mailing list