[snow-cvs] r42 - in trunk: examples/swixml lib src/java/snow src/lisp/snow src/lisp/snow/swing
Alessio Stalla
astalla at common-lisp.net
Wed Jan 6 22:46:01 UTC 2010
Author: astalla
Date: Wed Jan 6 17:46:01 2010
New Revision: 42
Log:
:id <sym> is now applicable to all widgets and has the added meaning that, if <sym> names a bound lexical variable, it is assigned the widget.
Removed snow-cells read conditionals.
Updated abcl (eliminated redefinition warnings).
Modified:
trunk/examples/swixml/helloworld.lisp
trunk/lib/abcl.jar
trunk/src/java/snow/Snow.java
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/snow.asd
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/start.lisp
trunk/src/lisp/snow/swing/swing.lisp
Modified: trunk/examples/swixml/helloworld.lisp
==============================================================================
--- trunk/examples/swixml/helloworld.lisp (original)
+++ trunk/examples/swixml/helloworld.lisp Wed Jan 6 17:46:01 2010
@@ -11,11 +11,12 @@
(panel (:layout "grow, wrap")
(label :text "Hello World!" :font (font "Georgia" 12 :bold)
:foreground :blue) ;;labelfor="tf"
- (child (setf tf (text-field :text "Snow")));;columns="20" TODO :var tf
+ (text-field :id tf :text "Snow");;columns="20" TODO :var tf
(button :text "Click Here" :on-action #'submit))
(panel (:layout "dock south")
(label :text "Clicks:" :font (font "Georgia" 36 :bold))
- (label :font (font "Georgia" 36 :bold) :text $(c? (str (var clicks)))))))))
+ (label :font (font "Georgia" 36 :bold) :text $(c? (str (var clicks)))))
+ (show self)))))
#||
The original example used the SwiXml idiom of coding a Java class to handle
Modified: trunk/lib/abcl.jar
==============================================================================
Binary files. No diff available.
Modified: trunk/src/java/snow/Snow.java
==============================================================================
--- trunk/src/java/snow/Snow.java (original)
+++ trunk/src/java/snow/Snow.java Wed Jan 6 17:46:01 2010
@@ -189,11 +189,7 @@
public static synchronized ScriptEngine init() throws ScriptException {
if(!init) {
initAux();
- lispEngine.eval("(pushnew :snow-cells *features*)");
lispEngine.eval("(asdf:oos 'asdf:load-op :snow)");
-
- //lispEngine.eval("(snow:install-graphical-debugger) (ohmygod)");
- //lispEngine.eval("(snow::inspect-object (snow::new \"javax.swing.JButton\"))");
init = true;
return lispEngine;
} else {
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Wed Jan 6 17:46:01 2010
@@ -182,7 +182,6 @@
(setf (gethash 'simple ht) 'make-simple-data-binding)
(setf (gethash 'var ht) 'make-simple-data-binding)
(setf (gethash 'bean ht) 'make-bean-data-binding)
- #+snow-cells
(progn
(setf (gethash 'cell ht) 'make-cell-data-binding)
(setf (gethash 'slot ht) 'make-slot-data-binding))
@@ -221,7 +220,7 @@
,*package*)) ;;Packages are externalizable: http://www.lispworks.com/documentation/HyperSpec/Body/03_bdbb.htm
(#\(
(let ((list (read stream)))
- (if #+snow-cells (eq (car list) 'cells:c?) #-snow-cells nil
+ (if (eq (car list) 'cells:c?)
`(make-data-binding 'cell ,list)
`(make-data-binding ',(car list) ,@(cdr list)))))
(t `(make-simple-data-binding ,(read stream)))))))
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Wed Jan 6 17:46:01 2010
@@ -30,8 +30,8 @@
(defpackage :snow
- (:use :common-lisp :java :cl-utilities :named-readtables #+snow-cells :cells)
- (:shadow #+snow-cells #:dbg)
+ (:use :common-lisp :java :cl-utilities :named-readtables :cells)
+ (:shadow #:dbg #:self)
(:export
;;Widgets
#:button
@@ -88,10 +88,6 @@
#:slot
#:var
#:simple-data-binding
- #+snow-cells
- #:c-expr
- #+snow-cells
- #:c-value
;;Various
#:call-in-gui-thread
#:color
@@ -115,5 +111,6 @@
#:new))
(defpackage :snow-user
- (: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
+ (:use :common-lisp :snow :java :ext :named-readtables :cells)
+ (:shadowing-import-from :snow
+ #:make-dialog-prompt-stream #:*gui-backend* #:self))
\ No newline at end of file
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Wed Jan 6 17:46:01 2010
@@ -32,7 +32,7 @@
(asdf:defsystem :snow
:serial t
:version "0.2"
- :depends-on (:cl-utilities :named-readtables #+snow-cells :cells)
+ :depends-on (:cl-utilities :named-readtables :cells)
:components ((:file "packages")
(:file "sexy-java")
(:file "utils")
@@ -41,7 +41,6 @@
(:file "widgets")
(:file "repl")
(:file "data-binding")
- #+snow-cells
(:file "cells")
(:file "backend")
(:file "debugger")
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Wed Jan 6 17:46:01 2010
@@ -188,7 +188,7 @@
(apply #'make-layout-manager self
(ensure-list (or layout-manager :default)))))
-(defun generate-default-children-processing-code (id children)
+(defun generate-default-children-processing-code (id children &optional env)
"Can be used inside a macro defining a container widget to generate the code to process its body, adding children to it."
(let ((code
(loop
@@ -198,18 +198,18 @@
((get (car form) 'widget-p) form)
(t `(let ((*parent* nil)) ,form)))
form))))
- `((let (,@(when id `((,id self))) (*parent* self))
+ `((let ((*parent* self))
, at code))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun common-widget-args ()
- '(layout binding (enabled-p t) (visible-p t) location size border font
+ '(id layout binding (enabled-p t) (visible-p t) location size border font
background foreground
on-mouse-click on-mouse-press on-mouse-release
on-mouse-enter on-mouse-exit
on-mouse-drag on-mouse-move))
(defun common-container-widget-args ()
- '(id (layout-manager :default)))
+ '((layout-manager :default)))
(defun common-widget-args-declarations ()
(let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
(common-widget-args))))
@@ -221,7 +221,9 @@
:for value :in (cdr args) by #'cddr
:when (not (member key filtered-keys))
:collect key :and
- :collect value)))
+ :collect value))
+ (defun filter-unevaluated-widget-args (args)
+ (filter-arglist args '(:id))))
(definterface setup-mouse-listeners *gui-backend*
(widget on-mouse-click on-mouse-press on-mouse-release
@@ -275,25 +277,36 @@
#+emacs (put 'define-container-widget 'lisp-indent-function 3)
(defmacro define-widget-macro (name arglist constructor &body body)
- `(progn
- (defmacro ,name ,(splice-into (common-widget-args) '&common-widget-args
- arglist)
- `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget.
- ,, at body
- self))
- (setf (get ',name 'widget-p) t)))
+ (with-unique-names (env)
+ `(progn
+ (defmacro ,name ,(append (splice-into (common-widget-args)
+ '&common-widget-args
+ arglist)
+ `(&environment ,env))
+ `(let ((self ,,constructor))
+ ;;The lexical variable self is always bound to the current widget.
+ ,(if id ;;id is one of the common args
+ (if (sys:variable-information id ,env) ;;id is lexically bound
+ `(progn
+ (setf ,id self)
+ ,, at body)
+ `(let ((,id self))
+ ,, at body))
+ `(progn ,, at body))
+ self))
+ (setf (get ',name 'widget-p) t))))
(define-widget-macro with-widget
- ((widget &rest args &key id &common-widget-args) &body body)
+ ((widget &rest args &key &common-widget-args) &body body)
`(dont-add ,widget)
`(progn
,@(generate-default-children-processing-code id body)
- (setup-widget self ,@(filter-arglist args '(:id)))))
+ (setup-widget self ,@(filter-unevaluated-widget-args args))))
(define-widget-macro child
(widget &rest args &key &common-widget-args)
`(dont-add ,widget)
- `(setup-widget self , at args))
+ `(setup-widget self ,@(filter-unevaluated-widget-args args)))
(defmacro define-widget (name keys constructor &body body)
"Convenience macro for defining a widget."
@@ -304,7 +317,7 @@
(let ((self (apply (function ,',constructor) args)))
(apply #'setup-widget self args)
self))
- ,@,args)
+ ,@(filter-unevaluated-widget-args ,args))
`(progn
,, at body))))
@@ -320,7 +333,7 @@
(apply #'setup-container-widget self args)
self))
;;remove id because it must not be evaluated
- ,@(filter-arglist ,args '(:id)))
+ ,@(filter-unevaluated-widget-args ,args))
`(progn
,(progn , at body) ;Bug in ABCL? ,, at body fails when body is NIL: Wrong number of arguments for CONS - it generates (cons (append (generate...) (apply...)))
,@(generate-default-children-processing-code id ,macro-body)))))
Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp (original)
+++ trunk/src/lisp/snow/start.lisp Wed Jan 6 17:46:01 2010
@@ -76,4 +76,5 @@
(snow-about))))))
(scroll (:layout "grow")
(gui-repl :dispose-on-close frame
- :environment `((*package* ,(find-package :snow-user)))))))
+ :environment `((*package* ,(find-package :snow-user))
+ (*readtable* ,(find-readtable 'snow:syntax)))))))
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Wed Jan 6 17:46:01 2010
@@ -29,8 +29,9 @@
;;; exception statement from your version.
(defpackage :snow-swing
- (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)
- (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
+ (:use :common-lisp :snow :java :ext :named-readtables :cells)
+ (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*
+ #:self))
(in-package :snow-swing)
More information about the snow-cvs
mailing list