[snow-cvs] r3 - in trunk: . src/java/snow src/lisp/snow src/lisp/snow/swing
Alessio Stalla
astalla at common-lisp.net
Tue Oct 6 19:59:56 UTC 2009
Author: astalla
Date: Tue Oct 6 15:59:55 2009
New Revision: 3
Log:
Rationalized widget construction in macros define-widget and define-container-widget. Now code is more functional instead of
procedural.
Modified:
trunk/changelog
trunk/src/java/snow/Snow.java
trunk/src/lisp/snow/inspector.lisp
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/start.lisp
trunk/src/lisp/snow/swing/swing.lisp
Modified: trunk/changelog
==============================================================================
--- trunk/changelog (original)
+++ trunk/changelog Tue Oct 6 15:59:55 2009
@@ -1,3 +1,10 @@
+2009-10-06
+ Rationalized widget construction in macros define-widget and
+ define-container-widget. Now code is more functional instead of
+ procedural.
+-----------------------
+old svn repo log below:
+
------------------------------------------------------------------------
r43 | snow | 2009-09-03 23:43:46 +0200 (gio, 03 set 2009) | 4 lines
Modified: trunk/src/java/snow/Snow.java
==============================================================================
--- trunk/src/java/snow/Snow.java (original)
+++ trunk/src/java/snow/Snow.java Tue Oct 6 15:59:55 2009
@@ -206,18 +206,18 @@
return (Invocable) lispEngine;
}
- public static void main(String[] args) {
- try {
- Snow.init();
- if(args.length == 0) { //Launch GUI REPL
- evalResource(Snow.class, "/snow/start.lisp", true);
- } else { //Launch regular ABCL
- org.armedbear.lisp.Main.main(args);
- }
- } catch (Exception e) {
- e.printStackTrace();
- }
+ public static void main(String[] args) {
+ try {
+ Snow.init();
+ if(args.length == 0) { //Launch GUI REPL
+ evalResource(Snow.class, "/snow/start.lisp", true);
+ } else { //Launch regular ABCL
+ org.armedbear.lisp.Main.main(args);
+ }
+ } catch (Exception e) {
+ e.printStackTrace();
}
-
+ }
+
}
Modified: trunk/src/lisp/snow/inspector.lisp
==============================================================================
--- trunk/src/lisp/snow/inspector.lisp (original)
+++ trunk/src/lisp/snow/inspector.lisp Tue Oct 6 15:59:55 2009
@@ -102,7 +102,7 @@
(defun inspector-panel (stack container &optional window)
(let ((descr (refreshed-descriptor (car stack))))
(panel (:id panel
- :layout-manager (:box :y))
+ :layout-manager '(:box :y))
(scroll (:layout "grow, wrap")
(with-widget ((text-area :text (object-description descr))
:id txt :layout "grow")
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Tue Oct 6 15:59:55 2009
@@ -80,10 +80,9 @@
(definterface make-layout-manager *gui-backend* (widget type &rest args))
-(defun generate-common-container-setup
- (&key (layout-manager :default) &allow-other-keys)
- `((setf (widget-property self :layout);;Swing specific!!
- (make-layout-manager self ,@(ensure-list layout-manager)))))
+(defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys)
+ (setf (widget-property self :layout);;Swing specific!!
+ (apply #'make-layout-manager self (ensure-list layout-manager))))
(defun generate-default-children-processing-code (id children)
(let ((code
@@ -102,22 +101,29 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun common-widget-args ()
- '(id layout binding (enabled-p t) location size))
+ '(layout binding (enabled-p t) location size))
(defun common-widget-args-declarations ()
(let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
(common-widget-args))))
`((declare (ignorable , at arg-names)))))
- (defun filter-widget-args (args)
- "Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion."
+ (defun filter-arglist (args filtered-keys)
(loop
:for key :in args :by #'cddr
:for value :in (cdr args) by #'cddr
- :when (not (member key '(:id :layout :binding :enabled-p :location
- :layout-manager :size)))
+ :when (not (member key filtered-keys))
:collect key :and
- :collect value)))
+ :collect value))
+ (defun filter-widget-args (args)
+ "Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion."
+ (filter-arglist args '(:id :layout :binding :enabled-p :location
+ :layout-manager :size))))
(defun common-widget-setup (self layout binding enabled-p location size)
+ (setup-widget self :layout layout :binding binding :enabled-p enabled-p
+ :location location :size size))
+
+(defun setup-widget (self &key layout binding (enabled-p t) location size
+ &allow-other-keys)
(when *parent* (add-child self *parent* layout))
(setf (widget-enabled-p self) enabled-p)
(when location (setf (widget-location self) location))
@@ -157,24 +163,29 @@
(with-unique-names (args)
`(define-widget-macro ,name
(&rest ,args &key ,@(common-widget-args) , at keys)
- `(,',constructor ,@(filter-widget-args ,args))
+ `(funcall (lambda (&rest args)
+ (let ((self (apply (function ,',constructor) args)))
+ (apply #'setup-widget self args)
+ self))
+ ,@,args)
`(progn
- (common-widget-setup self ,layout ,binding ,enabled-p ,location
- ,size)
,, at body))))
(defmacro define-container-widget (name keys constructor &body body)
(with-unique-names (args macro-body)
`(define-widget-macro ,name
- ((&rest ,args &key ,@(common-widget-args) layout-manager , at keys)
+ ((&rest ,args &key id ,@(common-widget-args) layout-manager , at keys)
&body ,macro-body)
- `(,',constructor ,@(filter-widget-args ,args))
+ `(funcall (lambda (&rest args)
+ (let ((self (apply (function ,',constructor) args)))
+ (apply #'setup-widget self args)
+ (apply #'setup-container-widget self args)
+ self))
+ ;;remove id because it must not be evaluated
+ ,@(filter-arglist ,args '(:id)))
`(progn
- ,@(apply #'generate-common-container-setup ,args)
,(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)
- (common-widget-setup self ,layout ,binding ,enabled-p ,location
- ,size)))))
+ ,@(generate-default-children-processing-code id ,macro-body)))))
(defmacro auto-add-children (&body body)
`(let ((*parent* self))
@@ -218,12 +229,13 @@
(definterface pack *gui-backend* (window))
;;Windows
-(definterface make-frame *gui-backend* (&key title visible-p on-close))
+(definterface make-frame *gui-backend* (&key title visible-p on-close
+ &allow-other-keys))
(define-container-widget frame (title visible-p on-close) make-frame)
(definterface make-dialog *gui-backend*
- (&key parent title modal-p visible-p))
+ (&key parent title modal-p visible-p &allow-other-keys))
(define-container-widget dialog (parent title modal-p visible-p)
make-dialog)
Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp (original)
+++ trunk/src/lisp/snow/start.lisp Tue Oct 6 15:59:55 2009
@@ -33,7 +33,7 @@
(with-gui ()
(frame (:id frame :title "ABCL - Snow REPL"
:size #C(800 300)
- :visible-p t :layout-manager (:mig "fill" "[fill]" "")
+ :visible-p t :layout-manager '(:mig "fill" "[fill]" "")
:on-close :exit)
(scroll (:layout "grow")
(gui-repl :dispose-on-close frame
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Tue Oct 6 15:59:55 2009
@@ -249,7 +249,7 @@
(compile nil
`(lambda ()
(let (, at environment)
- ;safe: *debugger-hook* is rebound
+ ;;safe: *debugger-hook* is rebound
(install-graphical-debugger)
(top-level::top-level-loop)))))))
(setf (widget-property text-area :document) repl-doc)
More information about the snow-cvs
mailing list