From astalla at common-lisp.net Tue Oct 6 19:59:56 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 06 Oct 2009 15:59:56 -0400 Subject: [snow-cvs] r3 - in trunk: . src/java/snow src/lisp/snow src/lisp/snow/swing Message-ID: 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) From astalla at common-lisp.net Mon Oct 12 20:29:11 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 12 Oct 2009 16:29:11 -0400 Subject: [snow-cvs] r4 - in trunk/src: java/snow lisp/snow lisp/snow/swing Message-ID: Author: astalla Date: Mon Oct 12 16:29:10 2009 New Revision: 4 Log: Properly implemented call-in-gui-thread for Swing. Added: trunk/src/java/snow/FunctionRunnable.java Modified: trunk/src/lisp/snow/snow.asd trunk/src/lisp/snow/swing/binding-jgoodies.lisp trunk/src/lisp/snow/swing/swing.lisp Added: trunk/src/java/snow/FunctionRunnable.java ============================================================================== --- (empty file) +++ trunk/src/java/snow/FunctionRunnable.java Mon Oct 12 16:29:10 2009 @@ -0,0 +1,53 @@ +/* + * FunctionRunnable.java + * + * Copyright (C) 2009 Alessio Stalla + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package snow; + +import org.armedbear.lisp.*; + +public class FunctionRunnable implements Runnable { + + private LispObject function; + + public FunctionRunnable(LispObject function) { + this.function = function; + } + + public void run() { + try { + function.execute(); + } catch(Throwable e) { + throw new RuntimeException(e); + } + } + +} \ 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 Mon Oct 12 16:29:10 2009 @@ -38,6 +38,7 @@ (:file "utils") (:file "snow") (:file "repl") + (:file "data-binding") (:file "backend") (:file "debugger") (:file "inspector"))) \ No newline at end of file Modified: trunk/src/lisp/snow/swing/binding-jgoodies.lisp ============================================================================== --- trunk/src/lisp/snow/swing/binding-jgoodies.lisp (original) +++ trunk/src/lisp/snow/swing/binding-jgoodies.lisp Mon Oct 12 16:29:10 2009 @@ -30,24 +30,6 @@ (in-package :snow) -(defvar *presentation-model*) - -(defclass binding () - ((converter :initarg :converter :initform nil :accessor binding-converter))) - -(defgeneric make-model (binding)) - -(defmethod make-model :around ((binding binding)) - (let ((model (call-next-method))) - (with-slots (converter) binding - (cond - ((functionp converter) - (new "snow.binding.Converter" model converter converter)) - ((consp converter) - (new "snow.binding.Converter" model (car converter) (cdr converter))) - ((null converter) model) - (t (error "~A is not a valid converter" converter)))))) - (defmethod bind-widget ((widget (jclass "javax.swing.JTextField")) binding) (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings" "bind" @@ -64,7 +46,7 @@ "com.jgoodies.binding.value.ValueModel") nil widget (make-model binding))) -(defmethod (setf widget-property) ((value binding) (widget (jclass "java.awt.Component")) name) +(defmethod (setf widget-property) ((value data-binding) (widget (jclass "java.awt.Component")) name) (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings" "bind" "javax.swing.JComponent" @@ -72,92 +54,3 @@ "com.jgoodies.binding.value.ValueModel") nil widget (dashed->camelcased name) (make-model value)) value) - -(defun trigger-commit (&optional (presentation-model *presentation-model*)) - (jcall (jmethod "com.jgoodies.binding.PresentationModel" - "triggerCommit") - presentation-model)) - -(defmacro form ((bean) &body body) - `(let ((*presentation-model* - (new "com.jgoodies.binding.PresentationModel" ,bean))) - , at body)) - -(defmacro make-action (args &body body) - (with-unique-names (presentation-model) - `(let ((,presentation-model *presentation-model*)) - (lambda ,args - (let ((*presentation-model* ,presentation-model)) - , at body))))) - -;;Concrete Binding implementations - -;;Simple Binding -(defclass simple-binding (binding) - ((variable :initarg :variable :reader binding-variable :initform (error "variable is required")))) - -(defun make-var (&optional obj) - (new "com.jgoodies.binding.value.ValueHolder" obj (jbool nil))) - -(defun var (var) - (invoke "getValue" var)) - -(defun (setf var) (value var) - (invoke "setValue" var value) - value) - -(defun make-simple-binding (variable) - (make-instance 'simple-binding :variable variable)) - -(defmethod make-model ((binding simple-binding)) - (binding-variable binding)) - -;;Bean Binding -(defclass bean-binding (binding) - ((object :initarg :object :reader binding-object - :initform (or *presentation-model* (error "object is required"))) - (property :initarg :property :reader binding-property - :initform (error "property is required")) - (observed-p :initarg :observed-p :reader binding-observed-p :initform t) - (buffered-p :initarg :buffered-p :reader binding-buffered-p :initform nil))) - -(defun make-bean-binding (object property &rest args) - (apply #'make-instance 'bean-binding :object object :property property - args)) - -(defmethod make-model ((binding bean-binding)) - (let ((presentation-model-class - (jclass "com.jgoodies.binding.PresentationModel"))) - (if (jinstance-of-p (binding-object binding) presentation-model-class) - (if (binding-buffered-p binding) - (jcall (jmethod presentation-model-class - "getBufferedModel" "java.lang.String") - (binding-object binding) - (dashed->camelcased (binding-property binding))) - (jcall (jmethod presentation-model-class - "getModel" "java.lang.String") - (binding-object binding) - (dashed->camelcased (binding-property binding)))) - (jnew (jconstructor "com.jgoodies.binding.beans.PropertyAdapter" - "java.lang.Object" "java.lang.String" - "boolean") - (binding-object binding) - (dashed->camelcased (binding-property binding)) - (jbool (binding-observed-p binding)))))) - -;;Default binding types -(defun default-binding-types () - (let ((ht (make-hash-table))) - (setf (gethash :simple ht) 'simple-binding) - (setf (gethash :bean ht) 'bean-binding) - ht)) - -(defparameter *binding-types* (default-binding-types)) - -(defun get-binding-class (binding-type) - (if (keywordp binding-type) - (gethash binding-type *binding-types*) - binding-type)) - -(defun make-binding (type &rest options) - (apply #'make-instance (get-binding-class type) options)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Mon Oct 12 16:29:10 2009 @@ -64,8 +64,8 @@ (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) - ;TODO... - (funcall fn)) + (jstatic "invokeLater" "javax.swing.SwingUtilities" + (new "snow.FunctionRunnable" fn))) ;;Base API implementation (defimplementation add-child (*gui-backend* :swing) From astalla at common-lisp.net Sun Oct 18 22:14:02 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 18 Oct 2009 18:14:02 -0400 Subject: [snow-cvs] r5 - in trunk: . src/java/org src/java/org/armedbear src/java/org/armedbear/lisp src/java/snow/binding src/lisp/snow src/lisp/snow/swing test/lib test/src/snow Message-ID: Author: astalla Date: Sun Oct 18 18:14:01 2009 New Revision: 5 Log: Added property change listener supporting nested properties (dot notation) and relative tests. Modified build.xml to launch JUnit tests. Added Java-friendly callback class. Small refactorings. Added: trunk/src/java/org/ trunk/src/java/org/armedbear/ trunk/src/java/org/armedbear/lisp/ trunk/src/java/org/armedbear/lisp/Callback.java trunk/src/java/snow/binding/BeanPropertyPathBinding.java trunk/src/lisp/snow/cells.lisp (contents, props changed) - copied, changed from r2, /trunk/src/lisp/snow/swing/cells.lisp trunk/src/lisp/snow/swing/data-binding.lisp (props changed) - copied unchanged from r4, /trunk/src/lisp/snow/swing/binding-jgoodies.lisp trunk/test/lib/ trunk/test/lib/junit.jar (contents, props changed) Removed: trunk/src/lisp/snow/swing/binding-jgoodies.lisp trunk/src/lisp/snow/swing/cells.lisp Modified: trunk/build.xml trunk/src/java/snow/binding/AccessorBinding.java trunk/src/lisp/snow/packages.lisp trunk/src/lisp/snow/snow.asd trunk/src/lisp/snow/swing/snow-swing.asd trunk/test/src/snow/BindingTest.java Modified: trunk/build.xml ============================================================================== --- trunk/build.xml (original) +++ trunk/build.xml Sun Oct 18 18:14:01 2009 @@ -29,11 +29,13 @@ snow.source.zip snow.source.tar -- create source distributions in ${dist.dir}. snow.clean - -- remove SNOW intermediate files + -- remove SNOW intermediate files + snow.test + -- run SNOW's JUnit tests - + @@ -72,9 +74,6 @@ - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Added: trunk/src/java/org/armedbear/lisp/Callback.java ============================================================================== --- (empty file) +++ trunk/src/java/org/armedbear/lisp/Callback.java Sun Oct 18 18:14:01 2009 @@ -0,0 +1,102 @@ +/* + * Callback.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Function.java 12079 2009-07-31 19:45:54Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.concurrent.Callable; + +public abstract class Callback extends Function { + + public Callback() { + super(); + } + + @Override + public LispObject execute() throws ConditionThrowable { + try { + return JavaObject.getInstance(call()); + } catch(Throwable e) { + throw new ConditionThrowable(new JavaException(e)); + } + } + + protected Object call() throws Throwable { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject arg0) throws ConditionThrowable { + try { + return JavaObject.getInstance(call(arg0.javaInstance())); + } catch(Exception e) { + throw new ConditionThrowable(new JavaException(e)); + } + } + + protected Object call(Object arg0) throws Exception, ConditionThrowable { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject arg0, LispObject arg1) throws ConditionThrowable { + try { + return JavaObject.getInstance(call(arg0.javaInstance(), arg1.javaInstance())); + } catch(Exception e) { + throw new ConditionThrowable(new JavaException(e)); + } + } + + protected Object call(Object arg0, Object arg1) throws Exception, ConditionThrowable { + return error(new WrongNumberOfArgumentsException(this)); + } + + /** TODO **/ + + public static Callback fromRunnable(final Runnable r) { + return new Callback() { + protected Object call() { + r.run(); + return null; + } + }; + } + + public static Callback fromCallable(final Callable c) { + return new Callback() { + protected Object call() throws Exception { + return c.call(); + } + }; + } + +} \ No newline at end of file Modified: trunk/src/java/snow/binding/AccessorBinding.java ============================================================================== --- trunk/src/java/snow/binding/AccessorBinding.java (original) +++ trunk/src/java/snow/binding/AccessorBinding.java Sun Oct 18 18:14:01 2009 @@ -68,12 +68,14 @@ public void setValue(Object value) { try { writer.execute(JavaObject.getInstance(value, true), place); - //valueChanged(value); } catch (ConditionThrowable e) { throw new RuntimeException(e); } } + /** + * Called from Lisp to notify a value change without invoking the writer. + */ public void valueChanged(Object value) { fireValueChange(oldValue, value, false); oldValue = value; Added: trunk/src/java/snow/binding/BeanPropertyPathBinding.java ============================================================================== --- (empty file) +++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Sun Oct 18 18:14:01 2009 @@ -0,0 +1,159 @@ +/* + * BeanPropertyPathBinding.java + * + * Copyright (C) 2008-2009 Alessio Stalla + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package snow.binding; + +import org.armedbear.lisp.ConditionThrowable; +import org.armedbear.lisp.JavaObject; +import org.armedbear.lisp.LispObject; +import java.beans.*; +import java.util.*; +import java.lang.reflect.*; +import com.jgoodies.binding.value.AbstractValueModel; +import com.jgoodies.binding.value.ValueModel; + +public class BeanPropertyPathBinding + extends AbstractValueModel + implements PropertyChangeListener { + + private String propertyName; + private Object object; + private Method removeMethod; + private BeanPropertyPathBinding nextListener; + private BeanPropertyPathBinding prevListener; + private String[] nextPropertyPath; + private Method reader; + private Method writer; + + private static final Class[] addRemovePropertyChangeListenerSignature = new Class[] { PropertyChangeListener.class }; + + public BeanPropertyPathBinding(Object o, String propertyPath) { + this(o, propertyPath.split("\\.")); + } + + protected BeanPropertyPathBinding(Object o, String[] propertyPath, + BeanPropertyPathBinding prevListener) { + this.prevListener = prevListener; + Class oClass = o.getClass(); + object = o; + propertyName = propertyPath[0]; + nextPropertyPath = new String[propertyPath.length - 1]; + System.arraycopy(propertyPath, 1, nextPropertyPath, 0, nextPropertyPath.length); + try { + Method addPropertyChangeListener = oClass.getMethod("addPropertyChangeListener", addRemovePropertyChangeListenerSignature); + addPropertyChangeListener.invoke(o, this); + } catch(Exception e) { + throw new RuntimeException(e); + } + PropertyDescriptor pd = getPropertyDescriptor(oClass, propertyName); + reader = pd.getReadMethod(); + writer = pd.getWriteMethod(); + if(nextPropertyPath.length > 0) { + Object subObj = getValue(); + if(subObj != null) { + nextListener = new BeanPropertyPathBinding(subObj, nextPropertyPath, this); + } + } + } + + public BeanPropertyPathBinding(Object o, String[] propertyPath) { + this(o, propertyPath, null); + } + + public void remove() { + try { + Method removePropertyChangeListener = object.getClass().getMethod("removePropertyChangeListener", addRemovePropertyChangeListenerSignature); + removePropertyChangeListener.invoke(object, this); + if(nextListener != null) { + nextListener.remove(); + } + } catch(Exception e) { + throw new RuntimeException(e); + } + } + + private static PropertyDescriptor getPropertyDescriptor(Class c, String propertyName) { + try { + BeanInfo info = Introspector.getBeanInfo(c); + for(PropertyDescriptor pd : info.getPropertyDescriptors()) { + if(pd.getName().equals(propertyName)) { + return pd; + } + } + } catch(Exception e) { + e.printStackTrace(); + } + return null; + } + + public void propertyChange(PropertyChangeEvent evt) { + if(propertyName.equals(evt.getPropertyName())) { + if(nextListener != null) { + nextListener.remove(); + } + if(nextPropertyPath.length > 0) { + Object subObj = evt.getNewValue(); + if(subObj != null) { + nextListener = new BeanPropertyPathBinding(subObj, nextPropertyPath, this); + } + } + fireValueChange(evt); + } + } + + protected void fireValueChange(PropertyChangeEvent evt) { + if(prevListener != null) { + prevListener.fireValueChange(evt); + } else { + fireValueChange(evt.getOldValue(), evt.getNewValue(), false); + } + } + + @Override + public Object getValue() { + try { + return reader.invoke(object); + } catch(Exception e) { + throw new RuntimeException(e); + } + } + + @Override + public void setValue(Object value) { + try { + writer.invoke(object, value); + } catch(Exception e) { + throw new RuntimeException(e); + } + } + +} Copied: trunk/src/lisp/snow/cells.lisp (from r2, /trunk/src/lisp/snow/swing/cells.lisp) ============================================================================== --- /trunk/src/lisp/snow/swing/cells.lisp (original) +++ trunk/src/lisp/snow/cells.lisp Sun Oct 18 18:14:01 2009 @@ -31,36 +31,36 @@ (in-package :snow) ;;Cellular slot Binding -(defmodel cells-binding (binding cells::model-object) +(defmodel cells-data-binding (data-binding cells::model-object) ((expression :initarg :expression :reader binding-expression :initform (error "expression is mandatory") :cell t) (writer :initarg writer :accessor binding-writer :initform nil :cell nil) (model :accessor binding-model :initform nil :cell nil))) -(defmethod initialize-instance :after ((obj cells-binding) &rest args) +(defmethod initialize-instance :after ((obj cells-data-binding) &rest args) (declare (ignore args)) (setf (binding-model obj) (make-cells-value-model obj))) -(defobserver expression ((binding cells-binding) new-value) +(defobserver expression ((binding cells-data-binding) new-value) (bwhen (it (binding-model binding)) (invoke "valueChanged" it new-value))) -(defun make-cells-binding (expression &optional writer) +(defun make-cells-data-binding (expression &optional writer) (check-type writer (or null function)) (let ((instance - (make-instance 'cells-binding :expression expression))) + (make-instance 'cells-data-binding :expression expression))) (setf (binding-writer instance) writer) instance)) -(defun make-slot-binding (object slot-accessor-name) - (make-cells-binding +(defun make-slot-data-binding (object slot-accessor-name) + (make-cells-data-binding (eval `(c? (,slot-accessor-name ,object))) (compile nil `(lambda (x) (setf (,slot-accessor-name ,object) x))))) -(defmethod make-model ((binding cells-binding)) +(defmethod make-model ((binding cells-data-binding)) (binding-model binding)) (defun make-cells-value-model (binding) Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Sun Oct 18 18:14:01 2009 @@ -33,21 +33,24 @@ (:use :common-lisp :java #+snow-cells :cells) (:shadow #+snow-cells #:dbg) (:export - ;Widgets + ;;Widgets #:button #:frame #:label #:panel #:text-field - ;Common operations on widgets + ;;Common operations on widgets #:hide #:pack #:show - ;Various + ;;Various #:install-graphical-debugger #:*parent* #:self - #:with-widget)) + #:with-widget + ;;Java + #:invoke + #:new)) (defpackage :snow-user (:use :common-lisp :snow :java :ext #+snow-cells :cells)) \ 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 Sun Oct 18 18:14:01 2009 @@ -39,6 +39,8 @@ (:file "snow") (:file "repl") (:file "data-binding") + #+snow-cells + (:file "cells") (:file "backend") (:file "debugger") (:file "inspector"))) \ No newline at end of file Modified: trunk/src/lisp/snow/swing/snow-swing.asd ============================================================================== --- trunk/src/lisp/snow/swing/snow-swing.asd (original) +++ trunk/src/lisp/snow/swing/snow-swing.asd Sun Oct 18 18:14:01 2009 @@ -34,6 +34,4 @@ :version "0.1" :depends-on () :components ((:file "swing") - (:file "binding-jgoodies") - #+snow-cells - (:file "cells"))) + (:file "data-binding"))) Added: trunk/test/lib/junit.jar ============================================================================== Binary file. No diff available. Modified: trunk/test/src/snow/BindingTest.java ============================================================================== --- trunk/test/src/snow/BindingTest.java (original) +++ trunk/test/src/snow/BindingTest.java Sun Oct 18 18:14:01 2009 @@ -10,68 +10,103 @@ import net.miginfocom.swing.MigLayout; -import org.junit.Test; +import org.junit.*; import com.jgoodies.binding.adapter.Bindings; import com.jgoodies.binding.beans.Model; import com.jgoodies.binding.beans.PropertyAdapter; import com.jgoodies.binding.value.ValueModel; +import java.beans.*; +import snow.binding.*; public class BindingTest { - @Test - public void testBinding() { - final Bean bean = new Bean(); - ValueModel valueModel = new PropertyAdapter(bean, Bean.PROPERTY, true); - JFrame frame = new JFrame("test"); - frame.setLayout(new MigLayout()); - JTextField field1 = new JTextField(20); - frame.add(field1, "wrap"); - JTextField field2 = new JTextField(20); - field2.setColumns(20); - frame.add(field2, "wrap"); - JLabel field3 = new JLabel(); - frame.add(field3, "wrap"); - Bindings.bind(field1, valueModel, true); - Bindings.bind(field2, valueModel, false); - Bindings.bind(field3, "text", new PropertyAdapter(bean, Bean.PROPERTY, true)); - JButton resetButton = new JButton("reset"); - resetButton.addActionListener(new ActionListener() { - - @Override - public void actionPerformed(ActionEvent e) { - bean.setProperty("cippalippa"); - } - - }); - frame.add(resetButton); - frame.setDefaultCloseOperation(frame.EXIT_ON_CLOSE); - frame.pack(); - frame.setVisible(true); + @Test + public void testBinding() { + final Bean bean = new Bean(); + ValueModel valueModel = new PropertyAdapter(bean, Bean.PROPERTY, true); + JFrame frame = new JFrame("test"); + frame.setLayout(new MigLayout()); + JTextField field1 = new JTextField(20); + frame.add(field1, "wrap"); + JTextField field2 = new JTextField(20); + field2.setColumns(20); + frame.add(field2, "wrap"); + JLabel field3 = new JLabel(); + frame.add(field3, "wrap"); + Bindings.bind(field1, valueModel, true); + Bindings.bind(field2, valueModel, false); + Bindings.bind(field3, "text", new PropertyAdapter(bean, Bean.PROPERTY, true)); + JButton resetButton = new JButton("reset"); + resetButton.addActionListener(new ActionListener() { + + @Override + public void actionPerformed(ActionEvent e) { + bean.setProperty("cippalippa"); + } + + }); + frame.add(resetButton); + frame.setDefaultCloseOperation(frame.EXIT_ON_CLOSE); + frame.pack(); + frame.setVisible(true); + } + + @Test + public void testPropertyPath() { + Bean bean = new Bean(); + bean.setBean(new Bean()); + bean.getBean().setProperty("ciao"); + ValueModel model = new BeanPropertyPathBinding(bean, "bean.property"); + final boolean[] flag = new boolean[] { true }; + model.addValueChangeListener(new PropertyChangeListener() { + public void propertyChange(PropertyChangeEvent evt) { + System.out.println("change: " + evt); + flag[0] = false; + } + }); + bean.getBean().setProperty("value2"); + if(flag[0]) { + Assert.fail("value was set but listener not fired"); } + flag[0] = true; + bean.getBean().setProperty("value2"); + if(!flag[0]) { + Assert.fail("value was set to same value and listener fired"); + } + } + + public static void main(String[] args) { + new BindingTest().testBinding(); + } + + public static class Bean extends Model { + + public static final String PROPERTY = "property"; - public static void main(String[] args) { - new BindingTest().testBinding(); + private String property = "cippalippa"; + private Bean bean; + + public String getProperty() { + System.out.println("get " + property); + return property; } - public static class Bean extends Model { - - public static final String PROPERTY = "property"; - - private String property = "cippalippa"; - - public String getProperty() { - System.out.println("get " + property); - return property; - } + public void setProperty(String property) { + String oldProperty = this.property; + this.property = property; + System.out.println("set " + property); + firePropertyChange(PROPERTY, oldProperty, property); + } - public void setProperty(String property) { - String oldProperty = this.property; - this.property = property; - System.out.println("set " + property); - firePropertyChange(PROPERTY, oldProperty, property); - } - + public Bean getBean() { + return bean; + } + + public void setBean(Bean bean) { + this.bean = bean; } + } + } From astalla at common-lisp.net Mon Oct 19 21:28:32 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 19 Oct 2009 17:28:32 -0400 Subject: [snow-cvs] r6 - in trunk: dist lib/cl-utilities-1.2.4 lib/cl-utilities-1.2.4/doc src/java/snow src/java/snow/binding src/lisp/snow Message-ID: Author: astalla Date: Mon Oct 19 17:28:31 2009 New Revision: 6 Log: Added dependency on cl-utilities for split-sequence and with-unique-names Started EL data binding Added: trunk/lib/cl-utilities-1.2.4/ trunk/lib/cl-utilities-1.2.4/README trunk/lib/cl-utilities-1.2.4/cl-utilities.asd trunk/lib/cl-utilities-1.2.4/collecting.lisp trunk/lib/cl-utilities-1.2.4/compose.lisp trunk/lib/cl-utilities-1.2.4/copy-array.lisp trunk/lib/cl-utilities-1.2.4/doc/ trunk/lib/cl-utilities-1.2.4/doc/collecting.html trunk/lib/cl-utilities-1.2.4/doc/compose.html trunk/lib/cl-utilities-1.2.4/doc/copy-array.html trunk/lib/cl-utilities-1.2.4/doc/expt-mod.html trunk/lib/cl-utilities-1.2.4/doc/extremum.html trunk/lib/cl-utilities-1.2.4/doc/index.html trunk/lib/cl-utilities-1.2.4/doc/once-only.html trunk/lib/cl-utilities-1.2.4/doc/read-delimited.html trunk/lib/cl-utilities-1.2.4/doc/rotate-byte.html trunk/lib/cl-utilities-1.2.4/doc/split-sequence.html trunk/lib/cl-utilities-1.2.4/doc/style.css trunk/lib/cl-utilities-1.2.4/doc/with-unique-names.html trunk/lib/cl-utilities-1.2.4/expt-mod.lisp trunk/lib/cl-utilities-1.2.4/extremum.lisp trunk/lib/cl-utilities-1.2.4/once-only.lisp trunk/lib/cl-utilities-1.2.4/package.lisp trunk/lib/cl-utilities-1.2.4/package.sh (contents, props changed) trunk/lib/cl-utilities-1.2.4/read-delimited.lisp trunk/lib/cl-utilities-1.2.4/rotate-byte.lisp trunk/lib/cl-utilities-1.2.4/split-sequence.lisp trunk/lib/cl-utilities-1.2.4/test.lisp trunk/lib/cl-utilities-1.2.4/with-unique-names.lisp trunk/src/lisp/snow/data-binding.lisp Removed: trunk/dist/ Modified: trunk/src/java/snow/Snow.java trunk/src/java/snow/binding/BeanPropertyPathBinding.java trunk/src/lisp/snow/compile-system.lisp trunk/src/lisp/snow/packages.lisp trunk/src/lisp/snow/sexy-java.lisp trunk/src/lisp/snow/snow.asd trunk/src/lisp/snow/utils.lisp Added: trunk/lib/cl-utilities-1.2.4/README ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/README Mon Oct 19 17:28:31 2009 @@ -0,0 +1,59 @@ +CL-UTILITIES Collection +======================= + +On Cliki.net , there +is a collection of Common Lisp Utilities, things that everybody writes +since they're not part of the official standard. There are some very +useful things there; the only problems are that they aren't +implemented as well as you'd like (some aren't implemented at all) and +they aren't conveniently packaged and maintained. It takes quite a bit +of work to carefully implement utilities for common use, commented +and documented, with error checking placed everywhere some dumb user +might make a mistake. + +The CLRFI process is a lot better thought out, +and will probably produce better standards than informal discussion on +a Wiki, but it has one problem: at the time of this writing, it's not +doing anything yet. Until the CLRFI process gets going, I think that a +high-quality collection of the informal standards on Cliki is a +valuable thing to have. It's here, and it's called cl-utilities. + +The home page is . + +Documentation +------------- + +Right now, documentation is at +. There are a few +differences, though: + +* The READ-DELIMITED function takes :start and :end keyword args. +* A WITH-GENSYMS function is provided for compatibility. +* COPY-ARRAY is not called SHALLOW-COPY-ARRAY. +* The ONCE-ONLY macro is included. + +Installation +------------ + +To install cl-utilities, you'll need to do one of two things: + +* Download cl-utilities into a place where asdf can find it, then + load it via asdf. You will also need to get the split-sequence + package, which cl-utilities depends on. + +-or- + +* Use asdf-install: (asdf-install:install :cl-utilities) + +Feedback +-------- + +The current maintainer is Peter Scott. If you have questions, bugs, +comments, or contributions, please send them to the cl-utilities-devel +mailing list, . + +License +------- + +The code in cl-utilities is in the public domain. Do whatever you want +with it. \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/cl-utilities.asd ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/cl-utilities.asd Mon Oct 19 17:28:31 2009 @@ -0,0 +1,33 @@ +;; -*- Lisp -*- + +(defpackage #:cl-utilities-system + (:use #:common-lisp #:asdf)) + +(in-package #:cl-utilities-system) + +(defsystem cl-utilities + :author "Maintained by Peter Scott" + :components ((:file "package") + (:file "split-sequence" :depends-on ("package")) + (:file "extremum" :depends-on ("package" + "with-unique-names" + "once-only")) + (:file "read-delimited" :depends-on ("package")) + (:file "expt-mod" :depends-on ("package")) + (:file "with-unique-names" :depends-on ("package")) + (:file "collecting" :depends-on ("package" + "with-unique-names" + "compose")) + (:file "once-only" :depends-on ("package")) + (:file "rotate-byte" :depends-on ("package")) + (:file "copy-array" :depends-on ("package")) + (:file "compose" :depends-on ("package")))) + +;; Sometimes we can accelerate byte rotation on SBCL by using the +;; SB-ROTATE-BYTE extension. This loads it. +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (handler-case (progn + (require :sb-rotate-byte) + (pushnew :sbcl-uses-sb-rotate-byte *features*)) + (error () (delete :sbcl-uses-sb-rotate-byte *features*)))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/collecting.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/collecting.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,84 @@ +;; Opinions differ on how a collection macro should work. There are +;; two major points for discussion: multiple collection variables and +;; implementation method. +;; +;; There are two main ways of implementing collection: sticking +;; successive elements onto the end of the list with tail-collection, +;; and using the PUSH/NREVERSE idiom. Tail-collection is usually +;; faster, except on CLISP, where PUSH/NREVERSE is a little faster. +;; +;; The COLLECTING macro only allows collection into one list, and you +;; can't nest them to get the same effect as multiple collection since +;; it always uses the COLLECT function. If you want to collect into +;; multiple lists, use the WITH-COLLECT macro. + +(in-package :cl-utilities) + +;; This should only be called inside of COLLECTING macros, but we +;; define it here to provide an informative error message and to make +;; it easier for SLIME (et al.) to get documentation for the COLLECT +;; function when it's used in the COLLECTING macro. +(defun collect (thing) + "Collect THING in the context established by the COLLECTING macro" + (error "Can't collect ~S outside the context of the COLLECTING macro" + thing)) + +(defmacro collecting (&body body) + "Collect things into a list forwards. Within the body of this macro, +the COLLECT function will collect its argument into the list returned +by COLLECTING." + (with-unique-names (collector tail) + `(let (,collector ,tail) + (labels ((collect (thing) + (if ,collector + (setf (cdr ,tail) + (setf ,tail (list thing))) + (setf ,collector + (setf ,tail (list thing)))))) + , at body) + ,collector))) + +(defmacro with-collectors ((&rest collectors) &body body) + "Collect some things into lists forwards. The names in COLLECTORS +are defined as local functions which each collect into a separate +list. Returns as many values as there are collectors, in the order +they were given." + (%with-collectors-check-collectors collectors) + (let ((gensyms-alist (%with-collectors-gensyms-alist collectors))) + `(let ,(loop for collector in collectors + for tail = (cdr (assoc collector gensyms-alist)) + nconc (list collector tail)) + (labels ,(loop for collector in collectors + for tail = (cdr (assoc collector gensyms-alist)) + collect `(,collector (thing) + (if ,collector + (setf (cdr ,tail) + (setf ,tail (list thing))) + (setf ,collector + (setf ,tail (list thing)))))) + , at body) + (values , at collectors)))) + +(defun %with-collectors-check-collectors (collectors) + "Check that all of the COLLECTORS are symbols. If not, raise an error." + (let ((bad-collector (find-if-not #'symbolp collectors))) + (when bad-collector + (error 'type-error + :datum bad-collector + :expected-type 'symbol)))) + +(defun %with-collectors-gensyms-alist (collectors) + "Return an alist mapping the symbols in COLLECTORS to gensyms" + (mapcar #'cons collectors + (mapcar (compose #'gensym + #'(lambda (x) + (format nil "~A-TAIL-" x))) + collectors))) + +;; Some test code which would be too hard to move to the test suite. +#+nil (with-collectors (one-through-nine abc) + (mapcar #'abc '(a b c)) + (dotimes (x 10) + (one-through-nine x) + (print one-through-nine)) + (terpri) (terpri)) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/compose.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/compose.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,51 @@ +;; This version of COMPOSE can only handle functions which take one +;; value and return one value. There are other ways of writing +;; COMPOSE, but this is the most commonly used. + +(in-package :cl-utilities) + +;; This is really slow and conses a lot. Fortunately we can speed it +;; up immensely with a compiler macro. +(defun compose (&rest functions) + "Compose FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (reduce #'funcall functions + :initial-value x + :from-end t))) + +;; Here's some benchmarking code that compares various methods of +;; doing the same thing. If the first method, using COMPOSE, is +;; notably slower than the rest, the compiler macro probably isn't +;; being run. +#+nil +(labels ((2* (x) (* 2 x))) + (macrolet ((repeat ((x) &body body) + (with-unique-names (counter) + `(dotimes (,counter ,x) + (declare (type (integer 0 ,x) ,counter) + (ignorable ,counter)) + , at body)))) + ;; Make sure the compiler macro gets run + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (time (repeat (30000000) (funcall (compose #'1+ #'2* #'1+) 6))) + (time (repeat (30000000) (funcall (lambda (x) (1+ (2* (1+ x)))) 6))) + (time (repeat (30000000) + (funcall (lambda (x) + (funcall #'1+ (funcall #'2* (funcall #'1+ x)))) + 6))))) + +;; Converts calls to COMPOSE to lambda forms with everything written +;; out and some things written as direct function calls. +;; Example: (compose #'1+ #'2* #'1+) => (LAMBDA (X) (1+ (2* (1+ X)))) +(define-compiler-macro compose (&rest functions) + (labels ((sharp-quoted-p (x) + (and (listp x) + (eql (first x) 'function) + (symbolp (second x))))) + `(lambda (x) ,(reduce #'(lambda (fun arg) + (if (sharp-quoted-p fun) + (list (second fun) arg) + (list 'funcall fun arg))) + functions + :initial-value 'x + :from-end t)))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/copy-array.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/copy-array.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,29 @@ +(in-package :cl-utilities) + +(defun copy-array (array &key (undisplace nil)) + "Shallow copies the contents of any array into another array with +equivalent properties. If array is displaced, then this function will +normally create another displaced array with similar properties, +unless UNDISPLACE is non-NIL, in which case the contents of the array +will be copied into a completely new, not displaced, array." + (declare (type array array)) + (let ((copy (%make-array-with-same-properties array undisplace))) + (unless (array-displacement copy) + (dotimes (n (array-total-size copy)) + (setf (row-major-aref copy n) (row-major-aref array n)))) + copy)) + +(defun %make-array-with-same-properties (array undisplace) + "Make an array with the same properties (size, adjustability, etc.) +as another array, optionally undisplacing the array." + (apply #'make-array + (list* (array-dimensions array) + :element-type (array-element-type array) + :adjustable (adjustable-array-p array) + :fill-pointer (when (array-has-fill-pointer-p array) + (fill-pointer array)) + (multiple-value-bind (displacement offset) + (array-displacement array) + (when (and displacement (not undisplace)) + (list :displaced-to displacement + :displaced-index-offset offset)))))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/doc/collecting.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/collecting.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,78 @@ + + + + Macro COLLECTING, WITH-COLLECTORS + + + + +

Macro COLLECTING

+

Syntax:

+ +

+ +

collecting form* => result

+ +

with-collectors (collector*) form* => result*

+

+

Arguments and Values:

+

+forms---an implicit +progn. + +

collector---a symbol which will have a collection function bound to it. + +

result---a collected list. + +

+

Description:

+

+collecting collects things into a list. Within the +body of this macro, the collect function will collect its +argument into result. + +

with-collectors collects some things into lists. The +collector names are defined as local functions which each +collect into a separate list. Returns as many values as there are +collectors, in the order they were given. + +

Exceptional situations:

+

+ +

If the collector names are not all symbols, a +type-error will be signalled. + +

Examples: + +

+(collecting (dotimes (x 10) (collect x))) => (0 1 2 3 4 5 6 7 8 9)
+
+(multiple-value-bind (a b)
+    (with-collectors (x y)
+      (x 1)
+      (y 2)
+      (x 3))
+  (append a b)) => (1 2 3)
+
+ +

Implementation notes:

+ +

Opinions differ on how a collection macro should work. There are +two major points for discussion: multiple collection variables and +implementation method. + +

There are two main ways of implementing collection: sticking +successive elements onto the end of the list with tail-collection, or +using the PUSH/NREVERSE idiom. Tail-collection is usually faster, +except on CLISP, where PUSH/NREVERSE is a little faster because it's +implemented in C which is always faster than Lisp bytecode.

+ +

The collecting macro only allows collection into one list, +and you can't nest them to get the same effect as multiple collection +since it always uses the collect function. If you want to +collect into multiple lists, use the with-collect macro.

+ +

Manual Index

+ + \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/doc/compose.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/compose.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,59 @@ + + + + Function COMPOSE + + + + +

Function COMPOSE

+ +

Syntax:

+ +

compose function* => composite-function

+ +

Arguments and Values:

+ +

function---a function designator.

+ +

composite-function---a function. + +

Description:

+ +

Composes its arguments into a single composite function. All its +arguments are assumed to designate functions which take one argument +and return one argument. + +

(funcall (compose f g) 42) is equivalent to (f (g +42)). Composition is right-associative. + +

Examples: + +

+;; Just to illustrate order of operations
+(defun 2* (x) (* 2 x))
+
+
+(funcall (compose #'1+ #'1+) 1) => 3
+(funcall (compose '1+ '2*) 5) => 11
+(funcall (compose #'1+ '2* '1+) 6) => 15 
+
+ +

Notes: +

If you're dealing with multiple arguments and return values, the +same concept can be used. Here is some code that could be useful: + +

+(defun mv-compose2 (f1 f2)
+  (lambda (&rest args)
+    (multiple-value-call f1 (apply f2 args))))
+    
+(defun mv-compose (&rest functions)
+  (if functions
+    (reduce #'mv-compose2 functions)
+    #'values))
+
+ +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/copy-array.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/copy-array.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,48 @@ + + + + Function COPY-ARRAY + + + + +

Function COPY-ARRAY

+

Syntax:

+ +

+ +

copy-array array &key undisplace => new-array +

+

Arguments and Values:

+

+array---an array.

+ +undisplace---a generalized boolean. The default is false.

+ +new-array---an array.

+ +

+

Description:

+ +

Shallow copies the contents of array into another array with +equivalent properties. If array is displaced, then this +function will normally create another displaced array with similar +properties, unless undisplace is true, in which case the +contents of array will be copied into a completely new, not +displaced, array.

+ +

Examples:

+
+(copy-array #(1 2 3)) => #(1 2 3)
+
+(let ((array #(1 2 3)))
+  (eq (copy-array array) array)) => NIL
+
+ +

Side Effects: None.

+ +

Affected By: None.

+ +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/expt-mod.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/expt-mod.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,60 @@ + + + + Function EXPT-MOD + + + + +

Function EXPT-MOD

+

Syntax:

+ +

expt-mod n exponent divisor => result +

+

Arguments and Values:

+

+n---a number.

+ +exponent---a number.

+ +divisor---a number.

+ +result---a number.

+ +

+

Description:

+

+expt-mod returns n raised to the exponent power, +modulo divisor. (expt-mod n exponent divisor) is +equivalent to (mod (expt n exponent) divisor). + +

+

Exceptional situations:

+

+ +

The exceptional situations are the same as those for (mod (expt +n exponent) divisor). + +

Notes:

+ +

One might wonder why we shouldn't simply write (mod (expt n +exponent) divisor). This function exists because the naïve +way of evaluating (mod (expt n exponent) divisor) produces a +gigantic intermediate result, which kills performance in applications +which use this operation heavily. The operation can be done much more +efficiently. Usually the compiler does this optimization +automatically, producing very fast code. However, we can't +depend on this behavior if we want to produce code that is +guaranteed not to perform abysmally on some Lisp implementations. + +

Therefore cl-utilities provides a standard interface to this +composite operation which uses mediocre code by default. Specific +implementations can usually do much better, but some do much +worse. We can get the best of both by simply using the same interface +and doing read-time conditionalization within cl-utilities to get +better performance on compilers like SBCL and Allegro CL which +optimize this operation. + +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/extremum.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/extremum.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,155 @@ + + + + Function EXTREMUM, EXTREMA, N-MOST-EXTREME + + + + +

Function EXTREMUM, EXTREMA, N-MOST-EXTREME

+

Syntax:

+ +

+ +

extremum sequence predicate &key key (start 0) end => morally-smallest-element

+

extrema sequence predicate &key key (start 0) end => morally-smallest-elements

+

n-most-extreme n sequence predicate &key key (start 0) end => n-smallest-elements

+

+

Arguments and Values:

+

+sequence---a proper sequence.

+ +predicate---a designator for a function of two +arguments that returns a generalized boolean.

+ +key---a designator for a function of one +argument, or nil.

+ +start, end---bounding index designators of sequence. The +defaults for start and end are 0 and nil, respectively.

+ +morally-smallest-element---the element of sequence that +would appear first if the sequence were ordered according to sort +using predicate and key + +

morally-smallest-elements---the identical elements of +sequence that would appear first if the sequence were ordered +according to sort +using predicate and key. If predicate states that +neither of two objects is before the other, they are considered +identical. + +n---a positive integer

+ +n-smallest-elements---the n elements of sequence that +would appear first if the sequence were ordered according to sort +using predicate and key + +

+

Description:

+

+extremum returns the element of sequence that would +appear first if the subsequence of sequence specified by +start and end were ordered according to sort +using predicate and key. + + +

extremum determines the relationship between two elements +by giving keys extracted from the elements to the +predicate. The first argument to the predicate function +is the part of one element of sequence extracted by the +key function (if supplied); the second argument is the part of +another element of sequence extracted by the key +function (if supplied). Predicate should return true if +and only if the first argument is strictly less than the second (in +some appropriate sense). If the first argument is greater than or +equal to the second (in the appropriate sense), then the +predicate should return false.

+ +

The argument to the key function is the sequence +element. The return value of the key function becomes an +argument to predicate. If key is not supplied or +nil, the sequence element itself is used. There is no +guarantee on the number of times the key will be called.

+ +

If the key and predicate always return, then the +operation will always terminate. This is guaranteed even if the +predicate does not really consistently represent a total order +(in which case the answer may be wrong). If the key +consistently returns meaningful keys, and the predicate does +reflect some total ordering criterion on those keys, then the answer +will be right

+ +

The predicate is assumed to consider two elements x +and y to be equal if (funcall predicate +x y) and (funcall +predicate y x) +are both false. + + +

The return value of (extremum predicate sequence :key key) +can be defined as (elt (sort +predicate (subseq sequence start end) :key key) 0) except when +sequence is empty (see Exceptional Situations), but may use +faster (less asymptotically complex) algorithms to find this answer. + +

extrema is similar to extremum, but it returns a list +of values. There can be more than one extremum, as determined by +predicate, and with extremum the choice of which +extremum to return is arbitrary. extrema returns all the +possible values which predicate determines to be equal. + +

n-most-extreme returns a list of n values without +testing for equality. It orders sequence in the same way as +extremum and extrema, then returns the first n +elements of the sorted sequence. + +

+

Exceptional situations:

+

+ +

If sequence is empty, then the error no-extremum is +signalled. Invoking the continue restart will cause +extremum to return nil. + + +

Should be prepared to signal an error of type type-error if +sequence is not a proper sequence. + +

If there are fewer than n values in the part of +sequence that n-most-extreme may operate on, it returns +all the values it can in sorted order and signals the warning +n-most-extreme-not-enough-elements. This warning stores the +given values for n and the relevant subsequence, and they may +be accessed with n-most-extreme-not-enough-elements-n and +n-most-extreme-not-enough-elements-subsequence, respectively. + +

Implementation notes:

+ +

There are two implementations of this function included in +cl-utilities, which should only concern you if you want to squeeze out +more efficiency, since the versions perform differently on different +inputs. + +

The function extremum-fastkey is used exactly like +extremum, but it calls key fewer times. If key is +fast, extremum-fastkey is slower than regular extremum, +but if key is hard to compute you can get significant gains in +speed. The extremum-fastkey function is more complicated than +extremum, and therefore may be more likely to contain +bugs. That said, it doesn't seem buggy.

+ +

Don't worry about the performance of passing #'identity as +key. This is optimized by a compiler macro.

+ +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/index.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/index.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,58 @@ + + + cl-utilities manual + + + + +

cl-utilities manual

+ +

Everybody writes some utilities because they're not part of the +standard but they're so broadly useful. This results in a lot of wheel +reinvention, and most reinventions are not as good as they should +be. The cl-utilities project is an actively maintained collection of +some of these utilities, with high-quality public-domain +implementations and decent documentation. + +

Table of contents:

+ + + +

Public domain, maintained by Peter Scott. For more information, see +the home page. + + + \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/doc/once-only.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/once-only.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,40 @@ + + + + Macro ONCE-ONLY + + + + +

Macro ONCE-ONLY

+

Syntax:

+ +

+ +

once-only (name*) form* +

+

Arguments and Values:

+

+name---a symbol.

+ +form---a form.

+ +

+

Description:

+

Meant to be used in macro code, once-only guards against +multiple evaluation of its arguments in macroexpansion code. Any +concise description would be far too vague to grasp, but this +thread on comp.lang.lisp does a decent job of explaining what +once-only does. + +

Notes:

+ +

The description here is frustratingly non-descriptive, and I +apologize for that. If you understand once-only and can give a +better explanation, I would be very grateful—not to mention +completely awed. + +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/read-delimited.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/read-delimited.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,88 @@ + + + + Function READ-DELIMITED + + + + +

Function READ-DELIMITED

+ +

Syntax:

+ +

read-delimited sequence stream &key start end delimiter test key => position, delimited-p

+ +

Arguments and Values:

+ +

sequence---a sequence.

+ +

stream---an input stream.

+

start, end---bounding index designators of +sequence. The defaults for start and end are 0 +and nil, respectively. + +

delimiter---a character. It defaults to #\newline.

+

test---a designator for a function of two +arguments that returns a generalized boolean.

+ +

key---a designator for a function of one +argument, or nil.

+

position---an integer greater than or equal to zero, +and less than or equal to the length of the sequence.

+ +

delimited-p---the result of the last invokation of test

+ +

Description:

+ +

Destructively modifies sequence by replacing +elements of sequence bounded by start and +end with elements read from stream.

+ +

Test is called with the actual read character, converted +by applying key to it, as the first and delimiter as the +second argument.

+ +

If a character is read for which (funcall test (funcall +key char) delimiter) is non-nil, +read-delimited terminates the copying even before reaching +end of file or the end of the bounding +designator.

+ +

read-delimited returns the index of the first +element of sequence that was not updated as the first +and the result of the last invokation of test as the second +value.

+ +

Sequence is destructively modified by copying successive +elements into it from stream. If the end of file +for stream is reached before copying all elements of the +subsequence, then the extra elements near the end of +sequence are not updated.

+ +

Exceptional situations: + +

If start and/or end are out of bounds, or if +start > end, then a +read-delimited-bounds-error error is signalled. This error is +passed the values of start, end, and sequence, +which can be read with read-delimited-bounds-error-start, +read-delimited-bounds-error-end, and +read-delimited-bounds-error-sequence, +respectively. + +

Implementation notes:

+ +

This is one of the more complex utilities, and the amount of +argument checking needed to do it properly is daunting. An amazing 76% +of the code is spent on making sure that the bounds are valid and in +order, and on what to do if they aren't. Once you remove all that, the +actual function which does all the work is quite simple, and unlikely +to contain bugs.

+ +

The design of this function makes it a little annoying to use, but +it is more efficient. If you need something more high-level, this +could be built on top of read-delimited fairly easily.

+ +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/rotate-byte.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/rotate-byte.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,65 @@ + + + + Function ROTATE-BYTE + + + + +

Function ROTATE-BYTE

+

Syntax:

+ +

+ +

rotate-byte count bytespec integer => result +

+

Arguments and Values:

+

+count---an integer.

+ +bytespec---a byte specifier.

+ +integer---an integer.

+ +result---an integer.

+ +

+

Description:

+ +

Rotates a field of bits within integer; specifically, returns an +integer that contains the bits of integer rotated count times +leftwards within the byte specified by bytespec, and elsewhere +contains the bits of integer.

+ +

Examples:

+
+(rotate-byte 3 (byte 32 0) 3) => 24
+(rotate-byte 3 (byte 5 5) 3) => 3
+(rotate-byte 6 (byte 8 0) -3) => -129
+
+ +

Side Effects: None.

+ +

Affected By: None.

+ +

Exceptional Situations: None.

+ +

See Also:

+ +

byte, +dpb, ldb + +

Implementation notes + +

SBCL provides the sb-rotate-byte extension to do this +efficiently. On SBCL, cl-utilities uses this extension +automatically. On other implementations, portable Common Lisp code is +used instead. + +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/split-sequence.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/split-sequence.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,106 @@ + + + + Function SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT + + + + +

Function SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT

+ +

Syntax:

+ +

split-sequence delimiter sequence &key count remove-empty-subseqs from-end start end test test-not key => list, index

+

split-sequence-if predicate sequence &key count remove-empty-subseqs from-end start end key => list, index

+ +

split-sequence-if-not predicate sequence &key count remove-empty-subseqs from-end start end key => list, index

+ +

Arguments and Values:

+ +

delimiter---an object.

+ +

predicate---a designator for a function of one argument that returns a generalized boolean.

+

sequence---a proper sequence.

+ +

count---an integer or nil. The default is nil.

+

remove-empty-subseqs---a generalized boolean. The default is false.

+ +

from-end---a generalized boolean. The default is false.

+

start, end---bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

+ +

test---a designator for a function of two arguments that returns a generalized boolean.

+

test-not---a designator for a function of two arguments that returns a generalized boolean.

+ +

key---a designator for a function of one argument, or nil.

+

list---a proper sequence.

+ +

index---an integer greater than or equal to zero, and less than or equal to the length of the sequence.

+ +

Description:

+ +

Splits sequence into a list of subsequences delimited by objects satisfying the test. + + +

List is a list of sequences of the same kind as sequence that has elements consisting of subsequences of sequence that were delimited in the argument by elements satisfying the test. Index is an index into sequence indicating the unprocessed region, suitable as an argument to subseq to continue processing in the same manner if desired. + + +

The count argument, if supplied, limits the number of subsequences in the first return value; if more than count delimited subsequences exist in sequence, the count leftmost delimited subsequences will be in order in the first return value, and the second return value will be the index into sequence at which processing stopped. + +

If from-end is non-null, sequence is conceptually processed from right to left, accumulating the subsequences in reverse order; from-end only makes a difference in the case of a non-null count argument. In the presence of from-end, the count rightmost delimited subsequences will be in the order that they are in sequence in the first return value, and the second is the index indicating the end of the unprocessed region. + + +

The start and end keyword arguments permit a certain subsequence of the sequence to be processed without the need for a copying stage; their use is conceptually equivalent to partitioning the subsequence delimited by start and end, only without the need for copying. + +

If remove-empty-subseqs is null (the default), then empty subsequences will be included in the result. + + +

In all cases, the subsequences in the first return value will be in the order that they appeared in sequence. + +

Examples:

+ +

+ (split-sequence:SPLIT-SEQUENCE #\Space "A stitch in time saves nine.")
+=>  ("A" "stitch" "in" "time" "saves" "nine.")
+    28
+ (split-sequence:SPLIT-SEQUENCE #\, "foo,bar ,baz, foobar , barbaz,")
+=>  ("foo" "bar " "baz" " foobar " " barbaz" "")
+    30
+
+ +

Implementation notes:

+ +

This code was written various people, and the license is +unknown. Since multiple people worked on it collaboratively and none +of them seem interested in keeping their intellectual property rights +to it, I'll assume that it is in the public domain (since the process +that produced it seems like the very essence of public domain). If +this is incorrect, please contact +me so we can get it straightened out.

+ +

The implementation itself is mature and well tested, and it is +widely used. The code should be fast enough for most people, but be +warned: it was written with vectors in mind, with list manipulation as +an afterthought. It does a lot of things that are quick on vectors but +slow on lists, and this can result in many orders of magnitude +slowdown in list benchmarks versus code written for lists. If this is +a problem for you, it should be straightforward to write your own, +such as the (more limited, not API compatible) example function given +by Szymon in this +mailing list post:

+ +

+(defun split-list-if (test list &aux (start list) (end list))
+  (loop while (and end (setq start (member-if-not test end)))
+	collect (ldiff start (setq end (member-if test start)))))
+

+ +

If this is an issue for enough people, I could optimize the code +and fix this problem. I'm reluctant to do that, however, since the +code works and is tested. It's usually more important to be correct +and non-buggy than to be fast, and I have been known to introduce +bugs.

+ +

Manual Index

+ + Added: trunk/lib/cl-utilities-1.2.4/doc/style.css ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/style.css Mon Oct 19 17:28:31 2009 @@ -0,0 +1,16 @@ +pre { + margin-right: 0.5cm; + border: thin black solid; + background: #F3EEEE; + padding: 0.5em; +} + +h1 { + font-family: sans-serif; + font-variant: small-caps; +} + +h2 { + font-family: sans-serif; + font-size: medium; +} \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/doc/with-unique-names.html ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/doc/with-unique-names.html Mon Oct 19 17:28:31 2009 @@ -0,0 +1,104 @@ + + + + Macro WITH-UNIQUE-NAMES + + + + +

Macro WITH-UNIQUE-NAMES

Syntax:

+ +with-unique-names ({var | (var + prefix)}*) declaration* + form* => result* + + +

Arguments and Values:

+

var---a symbol; + not evaluated.

+

prefix---a string designator; not + evaluated. The default is var.

+ +

declaration---a declare + expression; + not evaluated.

+

form---a form.

+

results---the values + returned by the forms.

+ +

Description:

Executes + a series of forms + with each + var bound to a fresh, + uninterned symbol. The + uninterned symbol is created as if by + a call to gensym with the + string denoted by prefix---or, if + prefix is not supplied, the string + + denoted by var---as argument. +

The variable + bindings + created are lexical + unless special + + declarations are specified. +

+ The forms are evaluated in order, and + the values of all but the last are discarded (that + is, the body is an implicit progn). +

Examples:

+

+
+    (with-unique-names (sym1) sym1)  =>  #:SYM13142
+    (with-unique-names ((sym1 "SYM1-")) sym1)  => #:SYM1-3143
+    (find-symbol "SYM1-3143")  =>  NIL, NIL
+    (with-unique-names ((sym #\Q)) sym) => #:Q3144
+    (with-unique-names ((sym1 :sym1-)) sym1) => #:SYM1-3145
+    (with-unique-names (sym1) (symbol-package sym1))  =>  NIL
+    (with-unique-names (sym8) (eq sym8 sym8))  =>  T
+    (with-unique-names (sym9) (set sym9 42) (symbol-value sym9))  =>  42
+
+ +

Side Effects:

+ Might increment *gensym-counter* once for each + var. +

Affected by:

*gensym-counter* + +

Exceptional Situations:

+ None. +

See Also:

+gensym, let +

+

+ +

Notes: +

This is an extension of the classic macro with-gensyms. In +fact, cl-utilities also exports with-gensyms, and it can be +used as usual. The exported with-gensyms is actually just an +alias for with-unique-names which gives a warning at +compile-time if the extensions of with-unique-names are used. + +

You are encouraged to use with-unique-names instead of +with-gensyms because it is a little more flexible and because +it tells what is going on rather than how it works. This is a somewhat +controversial point, so go ahead and use whichever you like if you +have an opinion on it. But if you're a newbie who honestly doesn't +care, please use with-unique-names. + +

Manual Index

+ + + \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/expt-mod.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/expt-mod.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,38 @@ +(in-package :cl-utilities) + +;; This is portable Common Lisp, but implementation-specific code may +;; improve performance considerably. +(defun expt-mod (n exponent modulus) + "As (mod (expt n exponent) modulus), but more efficient." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + ;; It's much faster on SBCL and ACL to use the simple method, and + ;; trust the compiler to optimize it. This may be the case on other + ;; Lisp implementations as well. + #+(or sbcl allegro) (mod (expt n exponent) modulus) + #-(or sbcl allegro) + (if (some (complement #'integerp) (list n exponent modulus)) + (mod (expt n exponent) modulus) + (loop with result = 1 + for i of-type fixnum from 0 below (integer-length exponent) + for sqr = n then (mod (* sqr sqr) modulus) + when (logbitp i exponent) do + (setf result (mod (* result sqr) modulus)) + finally (return result)))) + +;; If the compiler is going to expand compiler macros, we should +;; directly inline the simple expansion; this lets the compiler do all +;; sorts of fancy optimizations based on type information that +;; wouldn't be used to optimize the normal EXPT-MOD function. +#+(or sbcl allegro) +(define-compiler-macro expt-mod (n exponent modulus) + `(mod (expt ,n ,exponent) ,modulus)) + + +;; Here's some benchmarking code that may be useful. I probably +;; completely wasted my time declaring ITERATIONS to be a fixnum. +#+nil +(defun test (&optional (iterations 50000000)) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)) + (fixnum iterations)) + (time (loop repeat iterations do (mod (expt 12 34) 235))) + (time (loop repeat iterations do (expt-mod 12 34 235)))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/extremum.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/extremum.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,167 @@ +(in-package :cl-utilities) + +(define-condition no-extremum (error) () + (:report "Cannot find extremum of empty sequence") + (:documentation "Raised when EXTREMUM is called on an empty +sequence, since there is no morally smallest element")) + +(defun comparator (test &optional (key #'identity)) + "Comparison operator: auxilliary function used by EXTREMUM" + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (lambda (a b) (if (funcall test + (funcall key a) + (funcall key b)) + a + b))) + +;; This optimizes the case where KEY is #'identity +(define-compiler-macro comparator (&whole whole test + &optional (key #'identity)) + (if (eql key #'identity) + `(lambda (a b) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (if (funcall ,test a b) a b)) + whole)) + +;; The normal way of testing the if length of a proper sequence equals +;; zero is to just use (zerop (length sequence)). And, while some +;; implementations may optimize this, it's probably a good idea to +;; just write an optimized version and use it. This method can speed +;; up list length testing. +(defun zero-length-p (sequence) + "Is the length of SEQUENCE equal to zero?" + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (or (null sequence) + (when (vectorp sequence) + (zerop (length sequence))))) + +(declaim (inline zero-length-p)) + +;; Checks the length of the subsequence of SEQUENCE specified by START +;; and END, and if it's 0 then a NO-EXTREMUM error is signalled. This +;; should only be used in EXTREMUM functions. +(defmacro with-check-length ((sequence start end) &body body) + (once-only (sequence start end) + `(if (or (zero-length-p ,sequence) + (>= ,start (or ,end (length ,sequence)))) + (restart-case (error 'no-extremum) + (continue () + :report "Return NIL instead" + nil)) + (progn , at body)))) + +;; This is an extended version which takes START and END keyword +;; arguments. Any spec-compliant use of EXTREMUM will also work with +;; this extended version. +(defun extremum (sequence predicate + &key (key #'identity) (start 0) end) + "Returns the element of SEQUENCE that would appear first if the +sequence were ordered according to SORT using PREDICATE and KEY using +an unstable sorting algorithm. See http://www.cliki.net/EXTREMUM for +the full specification." + (with-check-length (sequence start end) + (reduce (comparator predicate key) sequence + :start start :end end))) + +;; This optimizes the case where KEY is #'identity +(define-compiler-macro extremum (&whole whole sequence predicate + &key (key #'identity) (start 0) end) + (if (eql key #'identity) + (once-only (sequence predicate start end) + `(with-check-length (,sequence ,start ,end) + (locally (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (reduce (comparator ,predicate) ,sequence + :start ,start :end ,end)))) + whole)) + +;; This is an "optimized" version which calls KEY less. REDUCE is +;; already so optimized that this will actually be slower unless KEY +;; is expensive. And on CLISP, of course, the regular version will be +;; much faster since built-in functions are ridiculously faster than +;; ones implemented in Lisp. Be warned, this isn't as carefully tested +;; as regular EXTREMUM and there's more that could go wrong. +(defun extremum-fastkey (sequence predicate + &key (key #'identity) (start 0) end) + "EXTREMUM implemented so that it calls KEY less. This is only faster +if the KEY function is so slow that calling it less often would be a +significant improvement; ordinarily it's slower." + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (with-check-length (sequence start end) + (let* ((smallest (elt sequence 0)) + (smallest-key (funcall key smallest)) + (current-index 0) + (real-end (or end (1- most-positive-fixnum)))) + (declare (type (integer 0) current-index real-end start) + (fixnum current-index real-end start)) + (map nil #'(lambda (x) + (when (<= start current-index real-end) + (let ((x-key (funcall key x))) + (when (funcall predicate + x-key + smallest-key) + (setf smallest x) + (setf smallest-key x-key)))) + (incf current-index)) + sequence) + smallest))) + +;; EXTREMA and N-MOST-EXTREME are based on code and ideas from Tobias +;; C. Rittweiler. They deal with the cases in which you are not +;; looking for a single extreme element, but for the extreme identical +;; elements or the N most extreme elements. + +(defun extrema (sequence predicate &key (key #'identity) (start 0) end) + (with-check-length (sequence start end) + (let* ((sequence (subseq sequence start end)) + (smallest-elements (list (elt sequence 0))) + (smallest-key (funcall key (elt smallest-elements 0)))) + (map nil + #'(lambda (x) + (let ((x-key (funcall key x))) + (cond ((funcall predicate x-key smallest-key) + (setq smallest-elements (list x)) + (setq smallest-key x-key)) + ;; both elements are considered equal if the predicate + ;; returns false for (PRED A B) and (PRED B A) + ((not (funcall predicate smallest-key x-key)) + (push x smallest-elements))))) + (subseq sequence 1)) + ;; We use NREVERSE to make this stable (in the sorting algorithm + ;; sense of the word 'stable'). + (nreverse smallest-elements)))) + + + +(define-condition n-most-extreme-not-enough-elements (warning) + ((n :initarg :n :reader n-most-extreme-not-enough-elements-n + :documentation "The number of elements that need to be returned") + (subsequence :initarg :subsequence + :reader n-most-extreme-not-enough-elements-subsequence + :documentation "The subsequence from which elements +must be taken. This is determined by the sequence and the :start and +:end arguments to N-MOST-EXTREME.")) + (:report (lambda (condition stream) + (with-slots (n subsequence) condition + (format stream "There are not enough elements in the sequence ~S~% to return the ~D most extreme elements" + subsequence n)))) + (:documentation "There are not enough elements in the sequence given +to N-MOST-EXTREME to return the N most extreme elements.")) + +(defun n-most-extreme (n sequence predicate &key (key #'identity) (start 0) end) + "Returns a list of the N elements of SEQUENCE that would appear +first if the sequence were ordered according to SORT using PREDICATE +and KEY with a stable sorting algorithm. If there are less than N +elements in the relevant part of the sequence, this will return all +the elements it can and signal the warning +N-MOST-EXTREME-NOT-ENOUGH-ELEMENTS" + (check-type n (integer 0)) + (with-check-length (sequence start end) + ;; This is faster on vectors than on lists. + (let ((sequence (subseq sequence start end))) + (if (> n (length sequence)) + (progn + (warn 'n-most-extreme-not-enough-elements + :n n :subsequence sequence) + (stable-sort (copy-seq sequence) predicate :key key)) + (subseq (stable-sort (copy-seq sequence) predicate :key key) + 0 n))))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/once-only.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/once-only.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,31 @@ +;; The ONCE-ONLY macro is hard to explain, hard to understand, hard to +;; write, hard to modify, and hard to live without once you figure out +;; how to use it. It's used in macros to guard against multiple +;; evaluation of arguments. My version is longer than most, but it +;; does some error checking and it gives gensym'd variables more +;; meaningful names than usual. + +(in-package :cl-utilities) + +(defun %check-once-only-names (names) + "Check that all of the NAMES are symbols. If not, raise an error." + ;; This only raises an error for the first non-symbol argument + ;; found. While this won't report multiple errors, it is probably + ;; more convenient to only report one. + (let ((bad-name (find-if-not #'symbolp names))) + (when bad-name + (error "ONCE-ONLY expected a symbol but got ~S" bad-name)))) + +(defmacro once-only (names &body body) + ;; Check the NAMES list for validity. + (%check-once-only-names names) + ;; Do not touch this code unless you really know what you're doing. + (let ((gensyms (loop for name in names collect (gensym (string name))))) + `(let (,@(loop for g in gensyms + for name in names + collect `(,g (gensym ,(string name))))) + `(let (,,@(loop for g in gensyms for n in names + collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms + collect `(,n ,g))) + , at body))))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/package.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/package.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,49 @@ +(defpackage :cl-utilities + (:use :common-lisp) + (:export #:split-sequence + #:split-sequence-if + #:split-sequence-if-not + #:partition + #:partition-if + #:partition-if-not + + #:extremum + #:no-extremum + #:extremum-fastkey + #:extrema + #:n-most-extreme + #:n-most-extreme-not-enough-elements + #:n-most-extreme-not-enough-elements-n + #:n-most-extreme-not-enough-elements-subsequence + + #:read-delimited + #:read-delimited-bounds-error + #:read-delimited-bounds-error-start + #:read-delimited-bounds-error-end + #:read-delimited-bounds-error-sequence + + #:expt-mod + + #:collecting + #:collect + #:with-collectors + + #:with-unique-names + #:with-gensyms + #:list-binding-not-supported + #:list-binding-not-supported-binding + + #:once-only + + #:rotate-byte + + #:copy-array + + #:compose)) + +#+split-sequence-deprecated +(defpackage :split-sequence + (:documentation "This package mimics SPLIT-SEQUENCE for compatibility with +packages that expect that system.") + (:use :cl-utilities) + (:export #:split-sequence #:split-sequence-if #:split-sequence-if-not)) Added: trunk/lib/cl-utilities-1.2.4/package.sh ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/package.sh Mon Oct 19 17:28:31 2009 @@ -0,0 +1,21 @@ +#!/bin/sh + +mkdir cl-utilities-1.2.4 +mkdir cl-utilities-1.2.4/doc +cp cl-utilities.asd package.sh collecting.lisp split-sequence.lisp expt-mod.lisp package.lisp compose.lisp extremum.lisp read-delimited.lisp test.lisp copy-array.lisp once-only.lisp rotate-byte.lisp with-unique-names.lisp README cl-utilities-1.2.4/ +cp doc/collecting.html doc/expt-mod.html doc/read-delimited.html doc/with-unique-names.html doc/compose.html doc/extremum.html doc/rotate-byte.html doc/copy-array.html doc/index.html doc/split-sequence.html doc/once-only.html doc/style.css cl-utilities-1.2.4/doc/ + +rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc + +tar -czvf cl-utilities-1.2.4.tar.gz cl-utilities-1.2.4/ +ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz +gpg -b -a ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz +ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz.asc ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc +rm -Rf cl-utilities-1.2.4/ + +scp cl-utilities-1.2.4.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz +scp cl-utilities-1.2.4.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz.asc +scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz +scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz.asc +scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz +scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz.asc Added: trunk/lib/cl-utilities-1.2.4/read-delimited.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/read-delimited.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,78 @@ +(in-package :cl-utilities) + +(defun read-delimited (sequence stream &key (start 0) end + (delimiter #\Newline) (test #'eql) (key #'identity)) + ;; Check bounds on SEQUENCE + (multiple-value-setq (start end) + (%read-delimited-bounds-check sequence start end)) + ;; Loop until we run out of input characters or places to put them, + ;; or until we encounter the delimiter. + (loop for index from start + for char = (read-char stream nil nil) + for test-result = (funcall test (funcall key char) delimiter) + while (and char + (< index end) + (not test-result)) + do (setf (elt sequence index) char) + finally (return-from read-delimited + (values index test-result)))) + +;; Conditions +;;;;;;;;;;;;; + +(define-condition read-delimited-bounds-error (error) + ((start :initarg :start :reader read-delimited-bounds-error-start) + (end :initarg :end :reader read-delimited-bounds-error-end) + (sequence :initarg :sequence :reader read-delimited-bounds-error-sequence)) + (:report (lambda (condition stream) + (with-slots (start end sequence) condition + (format stream "The bounding indices ~S and ~S are bad for a sequence of length ~S" + start end (length sequence))))) + (:documentation "There's a problem with the indices START and END +for SEQUENCE. See CLHS SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR issue.")) + +;; Error checking for bounds +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun %read-delimited-bounds-check (sequence start end) + "Check to make sure START and END are in bounds when calling +READ-DELIMITED with SEQUENCE" + (check-type start (or integer null)) + (check-type end (or integer null)) + (let ((start (%read-delimited-bounds-check-start sequence start end)) + (end (%read-delimited-bounds-check-end sequence start end))) + ;; Returns (values start end) + (%read-delimited-bounds-check-order sequence start end))) + +(defun %read-delimited-bounds-check-order (sequence start end) + "Check the order of START and END bounds, and return them in the +correct order." + (when (< end start) + (restart-case (error 'read-delimited-bounds-error + :start start :end end :sequence sequence) + (continue () + :report "Switch start and end" + (rotatef start end)))) + (values start end)) + +(defun %read-delimited-bounds-check-start (sequence start end) + "Check to make sure START is in bounds when calling READ-DELIMITED +with SEQUENCE" + (when (and start (< start 0)) + (restart-case (error 'read-delimited-bounds-error + :start start :end end :sequence sequence) + (continue () + :report "Use default for START instead" + (setf start 0)))) + start) + +(defun %read-delimited-bounds-check-end (sequence start end) + "Check to make sure END is in bounds when calling READ-DELIMITED +with SEQUENCE" + (when (and end (> end (length sequence))) + (restart-case (error 'read-delimited-bounds-error + :start start :end end :sequence sequence) + (continue () + :report "Use default for END instead" + (setf end nil)))) + (or end (length sequence))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/rotate-byte.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/rotate-byte.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,29 @@ +(in-package :cl-utilities) + +(defun rotate-byte (count bytespec integer) + "Rotates a field of bits within INTEGER; specifically, returns an +integer that contains the bits of INTEGER rotated COUNT times +leftwards within the byte specified by BYTESPEC, and elsewhere +contains the bits of INTEGER. See http://www.cliki.net/ROTATE-BYTE" + (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + #-sbcl + (let ((size (byte-size bytespec))) + (when (= size 0) + (return-from rotate-byte integer)) + (let ((count (mod count size))) + (labels ((rotate-byte-from-0 (count size integer) + (let ((bytespec (byte size 0))) + (if (> count 0) + (logior (ldb bytespec (ash integer count)) + (ldb bytespec (ash integer (- count size)))) + (logior (ldb bytespec (ash integer count)) + (ldb bytespec (ash integer (+ count size)))))))) + (dpb (rotate-byte-from-0 count size (ldb bytespec integer)) + bytespec + integer)))) + ;; On SBCL, we use the SB-ROTATE-BYTE extension. + #+sbcl-uses-sb-rotate-byte (sb-rotate-byte:rotate-byte count bytespec integer)) + +;; If we're using the SB-ROTATE-BYTE extension, we should inline our +;; call and let SBCL handle optimization from there. +#+sbcl-uses-sb-rotate-byte (declaim (inline rotate-byte)) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/split-sequence.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/split-sequence.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,244 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; ; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication here, which is kept +;;; to illustrate the relationship between the SPLIT-SEQUENCE +;;; functions and the CL:POSITION functions. + +;;; Examples: +;;; +;;; * (split-sequence #\; "a;;b;c") +;;; -> ("a" "" "b" "c"), 6 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t) +;;; -> ("a" "" "b" "c"), 0 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) +;;; -> ("c"), 4 +;;; +;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) +;;; -> ("a" "b" "c"), 6 +;;; +;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 +;;; +;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("ab" "a" "a" "ab" "a"), 11 +;;; +;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) +;;; -> ("oo" "bar" "b"), 9 + +;; cl-utilities note: the license of this file is unclear, and I don't +;; even know whom to contact to clarify it. If anybody objects to my +;; assumption that it is public domain, please contact me so I can do +;; something about it. Previously I required the split-sequence + ; package as a dependency, but that was so unwieldy that it was *the* +;; sore spot sticking out in the design of cl-utilities. -Peter Scott + +(in-package :cl-utilities) + +(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by delimiter. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +(CL:COMPLEMENT predicate). + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." ; Emacs syntax highlighting is broken, and this helps: " + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if-not predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if-not predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +;;; clean deprecation + +(defun partition (&rest args) + (apply #'split-sequence args)) + +(defun partition-if (&rest args) + (apply #'split-sequence-if args)) + +(defun partition-if-not (&rest args) + (apply #'split-sequence-if-not args)) + +(define-compiler-macro partition (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") + form) + +(define-compiler-macro partition-if (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") + form) + +(define-compiler-macro partition-if-not (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") + form) + +(pushnew :split-sequence *features*) Added: trunk/lib/cl-utilities-1.2.4/test.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/test.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,178 @@ +;; This file requires the FiveAM unit testing framework. +(eval-when (:compile-toplevel :load-toplevel :execute) + (asdf:oos 'asdf:load-op :fiveam) + (asdf:oos 'asdf:load-op :cl-utilities)) + +;; To run all the tests: +;; (5am:run! 'cl-utilities-tests::cl-utilities-suite) + +(defpackage :cl-utilities-tests + (:use :common-lisp :cl-utilities :5am)) + +(in-package :cl-utilities-tests) + +(def-suite cl-utilities-suite :description "Test suite for cl-utilities") +(in-suite cl-utilities-suite) + +;; These tests were taken directly from the comments at the top of +;; split-sequence.lisp +(test split-sequence + (is (tree-equal (values (split-sequence #\; "a;;b;c")) + '("a" "" "b" "c") :test #'equal)) + (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t)) + '("a" "" "b" "c") :test #'equal)) + (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t :count 1)) + '("c") :test #'equal)) + (is (tree-equal (values (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)) + '("a" "b" "c") :test #'equal)) + (is (tree-equal (values (split-sequence-if (lambda (x) + (member x '(#\a #\b))) + "abracadabra")) + '("" "" "r" "c" "d" "" "r" "") :test #'equal)) + (is (tree-equal (values (split-sequence-if-not (lambda (x) + (member x '(#\a #\b))) + "abracadabra")) + '("ab" "a" "a" "ab" "a") :test #'equal)) + (is (tree-equal (values (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)) + '("oo" "bar" "b") :test #'equal))) + +(test extremum + (is (= (extremum '(1 23 3 4 5 0) #'< :start 1 :end 4) 3)) + (signals no-extremum (extremum '() #'<)) + (is-false (handler-bind ((no-extremum #'continue)) + (extremum '() #'<))) + (is (= (extremum '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3)) + (is (= (locally (declare (optimize (speed 3) (safety 0))) + (extremum #(1 23 3 4 5 0) #'>)) + 23)) + (is (= (extremum-fastkey '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3))) + +(test extrema + (is (tree-equal (extrema '(3 2 1 1 2 1) #'<) + '(1 1 1))) + (is (tree-equal (extrema #(3 2 1 1 2 1) #'<) + '(1 1 1))) + (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :end 4) + '(1 1))) + (is (tree-equal (extrema '(3 2 1 1 2 1) #'< :end 4) + '(1 1))) + (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :start 3 :end 4) + '(1))) + (is (tree-equal (extrema '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr) + '((B . 1) (D . 1))))) + +(defmacro quietly (&body body) + "Perform BODY quietly, muffling any warnings that may arise" + `(handler-bind ((warning #'muffle-warning)) + , at body)) + +(test n-most-extreme + (is (tree-equal (n-most-extreme 1 '(3 1 2 1) #'>) + '(3))) + (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'>) + '(3 2))) + (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'<) + '(1 1))) + (is (tree-equal (n-most-extreme 1 '((A . 3) (B . 1) (C . 2) (D . 1)) #'> :key #'cdr) + '((A . 3)))) + (is (tree-equal (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr) + '((B . 1) (D . 1)))) + (is (tree-equal (quietly (n-most-extreme 20 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)) + '((B . 1) (D . 1) (C . 2) (A . 3)))) + (is (tree-equal (quietly (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2)) + '((B . 1)))) + (signals n-most-extreme-not-enough-elements (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2))) + +(defun delimited-test (&key (delimiter #\|) (start 0) end + (string "foogo|ogreogrjejgierjijri|bar|baz")) + (with-input-from-string (str string) + (let ((buffer (copy-seq " "))) + (multiple-value-bind (position delimited-p) + (read-delimited buffer str + :delimiter delimiter :start start :end end) + (declare (ignore delimited-p)) + (subseq buffer 0 position))))) + +(test read-delimited + (is (string= (delimited-test) "foogo")) + (is (string= (delimited-test :delimiter #\t) "foogo|ogreog")) + (is (string= (delimited-test :delimiter #\t :start 3) " foogo|ogr")) + (is (string= (delimited-test :start 3) " foogo")) + (is (string= (delimited-test :end 3) "foo")) + (is (string= (delimited-test :start 1 :end 3) " fo")) + (is (string= (delimited-test :string "Hello") "Hello")) + (is (string= (delimited-test :string "Hello" :start 3) " Hello")) + (is (string= (handler-bind ((read-delimited-bounds-error #'continue)) + (delimited-test :start 3 :end 1)) + " fo")) + (signals type-error (delimited-test :start 3/2)) + (signals read-delimited-bounds-error (delimited-test :start -3)) + (signals read-delimited-bounds-error (delimited-test :end 30)) + (signals read-delimited-bounds-error (delimited-test :start 3 :end 1))) + +;; Random testing would probably work better here. +(test expt-mod + (is (= (expt-mod 2 34 54) (mod (expt 2 34) 54))) + (is (= (expt-mod 20 3 54) (mod (expt 20 3) 54))) + (is (= (expt-mod 2.5 3.8 34.9) (mod (expt 2.5 3.8) 34.9))) + (is (= (expt-mod 2/5 3/8 34/9) (mod (expt 2/5 3/8) 34/9)))) + +(test collecting + (is (tree-equal (collecting (dotimes (x 10) (collect x))) + '(0 1 2 3 4 5 6 7 8 9))) + (is (tree-equal (collecting + (labels ((collect-it (x) (collect x))) + (mapcar #'collect-it (reverse '(c b a))))) + '(a b c))) + (is (tree-equal (multiple-value-bind (a b) + (with-collectors (x y) + (x 1) + (y 2) + (x 3)) + (append a b)) + '(1 3 2)))) + +(test with-unique-names + (is (equalp (subseq (with-unique-names (foo) + (string foo)) + 0 3) + "foo")) + (is (equalp (subseq (with-unique-names ((foo "bar")) + (string foo)) + 0 3) + "bar")) + (is (equalp (subseq (with-unique-names ((foo baz)) + (string foo)) + 0 3) + "baz")) + (is (equalp (subseq (with-unique-names ((foo #\y)) + (string foo)) + 0 1) + "y")) + (is (equalp (subseq (with-gensyms (foo) + (string foo)) + 0 3) + "foo"))) + +;; Taken from spec +(test rotate-byte + (is (= (rotate-byte 3 (byte 32 0) 3) 24)) + (is (= (rotate-byte 3 (byte 5 5) 3) 3)) + (is (= (rotate-byte 6 (byte 8 0) -3) -129))) + +(test copy-array + (let ((test-array (make-array '(10 10) :initial-element 5))) + (is (not (eq (copy-array test-array) test-array))) + (is (equalp (copy-array test-array) test-array)))) + +(test compose + (labels ((2* (x) (* 2 x))) + (is (= (funcall (compose #'1+ #'1+) 1) 3)) + (is (= (funcall (compose '1+ #'2*) 5) 11)) + (is (= (funcall (compose #'1+ #'2* '1+) 6) 15)) + ;; This should signal an undefined function error, since we're + ;; using '2* rather than #'2*, which means that COMPOSE will use + ;; the dynamic binding at the time it is called rather than the + ;; lexical binding here. + (signals undefined-function + (= (funcall (compose #'1+ '2* '1+) 6) 15)))) \ No newline at end of file Added: trunk/lib/cl-utilities-1.2.4/with-unique-names.lisp ============================================================================== --- (empty file) +++ trunk/lib/cl-utilities-1.2.4/with-unique-names.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,46 @@ +(in-package :cl-utilities) + +;; Defined at http://www.cliki.net/WITH-UNIQUE-NAMES + +(defmacro with-unique-names ((&rest bindings) &body body) + "Executes a series of forms with each var bound to a fresh, +uninterned symbol. See http://www.cliki.net/WITH-UNIQUE-NAMES" + `(let ,(mapcar #'(lambda (binding) + (multiple-value-bind (var prefix) + (%with-unique-names-binding-parts binding) + (check-type var symbol) + `(,var (gensym ,(format nil "~A" + (or prefix var)))))) + bindings) + , at body)) + +(defun %with-unique-names-binding-parts (binding) + "Return (values var prefix) from a WITH-UNIQUE-NAMES binding +form. If PREFIX is not given in the binding, NIL is returned to +indicate that the default should be used." + (if (consp binding) + (values (first binding) (second binding)) + (values binding nil))) + +(define-condition list-binding-not-supported (warning) + ((binding :initarg :binding :reader list-binding-not-supported-binding)) + (:report (lambda (condition stream) + (format stream "List binding ~S not supported by WITH-GENSYMS. +It will work, but you should use WITH-UNIQUE-NAMES instead." + (list-binding-not-supported-binding condition)))) + (:documentation "List bindings aren't supported by WITH-GENSYMS, and +if you want to use them you should use WITH-UNIQUE-NAMES instead. That +said, they will work; they'll just signal this warning to complain +about it.")) + + +(defmacro with-gensyms ((&rest bindings) &body body) + "Synonym for WITH-UNIQUE-NAMES, but BINDINGS should only consist of +atoms; lists are not supported. If you try to give list bindings, a +LIST-BINDING-NOT-SUPPORTED warning will be signalled, but it will work +the same way as WITH-UNIQUE-NAMES. Don't do it, though." + ;; Signal a warning for each list binding, if there are any + (dolist (binding (remove-if-not #'listp bindings)) + (warn 'list-binding-not-supported :binding binding)) + ;; Otherwise, this is a synonym for WITH-UNIQUE-NAMES + `(with-unique-names ,bindings , at body)) \ No newline at end of file Modified: trunk/src/java/snow/Snow.java ============================================================================== --- trunk/src/java/snow/Snow.java (original) +++ trunk/src/java/snow/Snow.java Mon Oct 19 17:28:31 2009 @@ -51,168 +51,182 @@ public abstract class Snow { - private static boolean init = false; - private static ScriptEngine lispEngine; - private static final String fileSeparator = System.getProperty("file.separator"); - - private static final String fixDirPath(String path) { - if(!path.endsWith(fileSeparator)) { - path += fileSeparator; - } - return path; + private static boolean init = false; + private static ScriptEngine lispEngine; + private static final String fileSeparator = System.getProperty("file.separator"); + + private static final String fixDirPath(String path) { + if(!path.endsWith(fileSeparator)) { + path += fileSeparator; } - - public static synchronized ScriptEngine init() throws ScriptException { - if(!init) { - lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp"); - URL url = Snow.class.getResource("/snow/snow.asd"); - if(url == null) { - throw new RuntimeException("snow.asd not found in classpath: have you installed Snow correctly?"); - } - String baseDir; - String libDir; - if(!"file".equals(url.getProtocol())) { - if("jar".equals(url.getProtocol())) { - ZipInputStream extractor = null; - try { - String tmpDir = System.getProperty("java.io.tmpdir"); - if(tmpDir != null && fileSeparator != null) { - tmpDir = fixDirPath(tmpDir); - String jarUrlStr = url.getPath(); - int bangPos = jarUrlStr.indexOf('!'); - if(bangPos >= 0) { - jarUrlStr = jarUrlStr.substring(0, bangPos); - } - URL jarUrl = new URL(jarUrlStr); - extractor = new ZipInputStream(jarUrl.openStream()); - int targetDirIndex = 0; - File targetDir; - do { - targetDir = new File(tmpDir + "snow" + (targetDirIndex++)); - } while(targetDir.exists()); - targetDir.mkdir(); - targetDir.deleteOnExit(); - baseDir = targetDir.getAbsolutePath(); - baseDir = fixDirPath(baseDir); - libDir = baseDir; - for(ZipEntry entry = extractor.getNextEntry(); entry != null; entry = extractor.getNextEntry()) { - File extracted = new File(baseDir + entry.getName()); - extracted.deleteOnExit(); - if(entry.isDirectory()) { - extracted.mkdirs(); - } else { - extracted.getParentFile().mkdirs(); - byte[] buf = new byte[(int)entry.getSize()]; //probably inefficient - int read = 0; - while(true) { - int justRead = extractor.read(buf, read, buf.length - read); - if(justRead >= 0 && read < buf.length) { - read += justRead; - } else { - break; - } - } - FileOutputStream fos = new FileOutputStream(extracted); - fos.write(buf); - fos.flush(); - fos.close(); - } - extracted.setLastModified(entry.getTime()); - System.out.println("Extracted " + extracted.getAbsolutePath()); - } - } else { - throw new RuntimeException("Cannot extract jar " + url + " - no temp dir or file separator defined"); - } - } catch(Exception e) { - throw new RuntimeException("Cannot extract jar " + url, e); - } finally { - if(extractor != null) { - try { - extractor.close(); - } catch (IOException e) { - System.err.println("Couldn't close jar extractor: " + e.getMessage()); - e.printStackTrace(); - } - } - } + return path; + } + + /** + * This method is public only because it needs to be called from Lisp. + * Do not call it. + */ + public static synchronized void initAux() throws ScriptException { + if(!init) { + lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp"); + URL url = Snow.class.getResource("/snow/snow.asd"); + if(url == null) { + throw new RuntimeException("snow.asd not found in classpath: have you installed Snow correctly?"); + } + String baseDir; + String libDir; + if(!"file".equals(url.getProtocol())) { + if("jar".equals(url.getProtocol())) { + ZipInputStream extractor = null; + try { + String tmpDir = System.getProperty("java.io.tmpdir"); + if(tmpDir != null && fileSeparator != null) { + tmpDir = fixDirPath(tmpDir); + String jarUrlStr = url.getPath(); + int bangPos = jarUrlStr.indexOf('!'); + if(bangPos >= 0) { + jarUrlStr = jarUrlStr.substring(0, bangPos); + } + URL jarUrl = new URL(jarUrlStr); + extractor = new ZipInputStream(jarUrl.openStream()); + int targetDirIndex = 0; + File targetDir; + do { + targetDir = new File(tmpDir + "snow" + (targetDirIndex++)); + } while(targetDir.exists()); + targetDir.mkdir(); + targetDir.deleteOnExit(); + baseDir = targetDir.getAbsolutePath(); + baseDir = fixDirPath(baseDir); + libDir = baseDir; + for(ZipEntry entry = extractor.getNextEntry(); entry != null; entry = extractor.getNextEntry()) { + File extracted = new File(baseDir + entry.getName()); + extracted.deleteOnExit(); + if(entry.isDirectory()) { + extracted.mkdirs(); } else { - throw new RuntimeException("Unsupported URL for snow.asd: " + url + - " make sure it is a regular file or is in a jar."); + extracted.getParentFile().mkdirs(); + byte[] buf = new byte[(int)entry.getSize()]; //probably inefficient + int read = 0; + while(true) { + int justRead = extractor.read(buf, read, buf.length - read); + if(justRead >= 0 && read < buf.length) { + read += justRead; + } else { + break; + } + } + FileOutputStream fos = new FileOutputStream(extracted); + fos.write(buf); + fos.flush(); + fos.close(); } + extracted.setLastModified(entry.getTime()); + System.out.println("Extracted " + extracted.getAbsolutePath()); + } } else { - URI uri; - try { - uri = url.toURI(); - } catch (URISyntaxException e) { - throw new RuntimeException(e); - } - File f = new File(uri); - baseDir = fixDirPath(f.getParentFile().getParent()); - libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator; + throw new RuntimeException("Cannot extract jar " + url + " - no temp dir or file separator defined"); + } + } catch(Exception e) { + throw new RuntimeException("Cannot extract jar " + url, e); + } finally { + if(extractor != null) { + try { + extractor.close(); + } catch (IOException e) { + System.err.println("Couldn't close jar extractor: " + e.getMessage()); + e.printStackTrace(); + } } - lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)"); - 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 { - throw new RuntimeException("Already initialized"); + throw new RuntimeException("Unsupported URL for snow.asd: " + url + + " make sure it is a regular file or is in a jar."); } - } - - public static synchronized ScriptEngine initIfNecessary() throws ScriptException { - if(!init) { - init(); - } - return lispEngine; - } - - public static Object evalResource(Class aClass, String resourcePath) throws ScriptException { - return evalResource(aClass, resourcePath, true); - } - - public static Object evalResource(Class aClass, String resourcePath, boolean compileItFirst) throws ScriptException { - Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath)); - return evalResource(r, compileItFirst); - } - - public static Object evalResource(Reader reader) throws ScriptException { - return evalResource(reader, true); - } - - public static Object evalResource(Reader reader, boolean compileItFirst) throws ScriptException { - initIfNecessary(); - if(compileItFirst) { - return getCompilable().compile(reader).eval(); - } else { - return lispEngine.eval(reader); + } else { + URI uri; + try { + uri = url.toURI(); + } catch (URISyntaxException e) { + throw new RuntimeException(e); } + File f = new File(uri); + baseDir = fixDirPath(f.getParentFile().getParent()); + libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator; + } + lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)"); + lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)"); + lispEngine.eval("(pushnew #P\"" + libDir + "cl-utilities-1.2.4/\" asdf:*central-registry* :test #'equal)"); + lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)"); + lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)"); } - - public static ScriptEngine getScriptEngine() { - return lispEngine; + } + + 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 { + throw new RuntimeException("Already initialized"); } - - public static Compilable getCompilable() { - return (Compilable) lispEngine; + } + + public static synchronized ScriptEngine initIfNecessary() throws ScriptException { + if(!init) { + init(); } + return lispEngine; + } - public static Invocable getInvocable() { - return (Invocable) lispEngine; + public static Object evalResource(Class aClass, String resourcePath) throws ScriptException { + return evalResource(aClass, resourcePath, true); + } + + public static Object evalResource(Class aClass, String resourcePath, boolean compileItFirst) throws ScriptException { + Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath)); + return evalResource(r, compileItFirst); + } + + public static Object evalResource(Reader reader) throws ScriptException { + return evalResource(reader, true); + } + + public static Object evalResource(Reader reader, boolean compileItFirst) throws ScriptException { + initIfNecessary(); + if(compileItFirst) { + return getCompilable().compile(reader).eval(); + } else { + return lispEngine.eval(reader); } - + } + + public static ScriptEngine getScriptEngine() { + return lispEngine; + } + + public static Compilable getCompilable() { + return (Compilable) lispEngine; + } + + public static Invocable getInvocable() { + 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); + lispEngine.eval("(TOP-LEVEL::TOP-LEVEL)"); + //org.armedbear.lisp.Main.main(args); } } catch (Exception e) { e.printStackTrace(); Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java ============================================================================== --- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original) +++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Mon Oct 19 17:28:31 2009 @@ -60,6 +60,10 @@ this(o, propertyPath.split("\\.")); } + public BeanPropertyPathBinding(Object o, String[] propertyPath) { + this(o, propertyPath, null); + } + protected BeanPropertyPathBinding(Object o, String[] propertyPath, BeanPropertyPathBinding prevListener) { this.prevListener = prevListener; @@ -85,10 +89,6 @@ } } - public BeanPropertyPathBinding(Object o, String[] propertyPath) { - this(o, propertyPath, null); - } - public void remove() { try { Method removePropertyChangeListener = object.getClass().getMethod("removePropertyChangeListener", addRemovePropertyChangeListenerSignature); Modified: trunk/src/lisp/snow/compile-system.lisp ============================================================================== --- trunk/src/lisp/snow/compile-system.lisp (original) +++ trunk/src/lisp/snow/compile-system.lisp Mon Oct 19 17:28:31 2009 @@ -3,15 +3,16 @@ (unwind-protect (unless (progn - (pushnew #P"snow/" asdf:*central-registry* :test #'equal) - (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal) - (pushnew #P"cells/" asdf:*central-registry* :test #'equal) + #|(pushnew #P"snow/" asdf:*central-registry* :test #'equal) + (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal) + (pushnew #P"cl-utilities-1.2.4/" asdf:*central-registry* :test #'equal) + (pushnew #P"cells/" asdf:*central-registry* :test #'equal) (pushnew #P"cells/utils-kt/" asdf:*central-registry* :test #'equal) - (pushnew :snow-cells *features*) - - (format t "asdf:*central-registry*: ~A" asdf:*central-registry*) - - (asdf:oos 'asdf:compile-op :snow) - t) - (format t "failed")) + (pushnew :snow-cells *features*)|# + (jstatic "initAux" "snow.Snow") + (format t "asdf:*central-registry*: ~A" asdf:*central-registry*) + + (asdf:oos 'asdf:compile-op :snow) + t) + (format t "failed")) (quit)) \ No newline at end of file Added: trunk/src/lisp/snow/data-binding.lisp ============================================================================== --- (empty file) +++ trunk/src/lisp/snow/data-binding.lisp Mon Oct 19 17:28:31 2009 @@ -0,0 +1,157 @@ +;;; binding-jgoodies.lisp +;;; +;;; Copyright (C) 2008-2009 Alessio Stalla +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package :snow) + +(defclass data-binding () + ((converter :initarg :converter :initform nil :accessor binding-converter))) + +(defgeneric make-model (data-binding)) + +(defmethod make-model :around ((binding data-binding)) + "Wraps the model with a converter if one was specified for the binding" + (let ((model (call-next-method))) + (with-slots (converter) binding + (cond + ((functionp converter) + (new "snow.binding.Converter" model converter converter)) + ((consp converter) + (new "snow.binding.Converter" model (car converter) (cdr converter))) + ((null converter) model) + (t (error "~A is not a valid converter" converter)))))) + +(defgeneric bind-widget (widget data-binding) + (:documentation "Establishes a 'data binding' between a GUI component and a data binding target. Every time the data held by the component or by the target changes, the other one will be updated accordingly.")) + +;;Concrete Binding implementations + +;;Simple Binding +(defclass simple-data-binding (data-binding) + ((variable :initarg :variable :reader binding-variable :initform (error "variable is required")))) + +(defun make-var (&optional obj) + (new "com.jgoodies.binding.value.ValueHolder" obj (jbool nil))) + +(defun var (var) + (invoke "getValue" var)) + +(defun (setf var) (value var) + (invoke "setValue" var value) + value) + +(defun make-simple-data-binding (variable) + (make-instance 'simple-data-binding :variable variable)) + +(defmethod make-model ((binding simple-data-binding)) + (binding-variable binding)) + +;;Bean Binding + +;;JGoodies Binding presentation model +(defvar *presentation-model* nil) + +(defun trigger-commit (&optional (presentation-model *presentation-model*)) + (jcall (jmethod "com.jgoodies.binding.PresentationModel" + "triggerCommit") + presentation-model)) + +(defmacro form ((bean) &body body) + `(let ((*presentation-model* + (new "com.jgoodies.binding.PresentationModel" ,bean))) + , at body)) + +(defclass bean-data-binding (data-binding) + ((object :initarg :object :reader binding-object + :initform (or *presentation-model* (error "object is required"))) + (property :initarg :property :reader binding-property + :initform (error "property is required")) + (observed-p :initarg :observed-p :reader binding-observed-p :initform t) + (buffered-p :initarg :buffered-p :reader binding-buffered-p :initform nil))) + +(defun make-bean-data-binding (object property &rest args) + (apply #'make-instance 'bean-data-binding :object object :property property + args)) + +(defmethod make-model ((binding bean-data-binding)) + (let ((presentation-model-class + (jclass "com.jgoodies.binding.PresentationModel"))) + (if (jinstance-of-p (binding-object binding) presentation-model-class) + (if (binding-buffered-p binding) + (jcall (jmethod presentation-model-class + "getBufferedModel" "java.lang.String") + (binding-object binding) + (dashed->camelcased (binding-property binding))) + (jcall (jmethod presentation-model-class + "getModel" "java.lang.String") + (binding-object binding) + (dashed->camelcased (binding-property binding)))) + (jnew (jconstructor "com.jgoodies.binding.beans.PropertyAdapter" + "java.lang.Object" "java.lang.String" + "boolean") + (binding-object binding) + (dashed->camelcased (binding-property binding)) + (jbool (binding-observed-p binding)))))) + +;;EL data binding +(defvar *bean-factory* + #'(lambda (bean-name) + (declare (ignore bean-name)) + (error "No bean factory defined - please bind *bean-factory*")) + "A callback called by the EL engine with a single argument, the name of a bean to fetch from the application.") + +;;For EL data bindings we reuse simple-data-binding, since its 'variable' can +;;really be any JGoodies ValueModel +(defun make-el-data-binding (el-expr) + (let* ((splitted-expr (split-sequence #\. el-expr)) + (obj (funcall *bean-factory* (car splitted-expr))) + (path (cdr splitted-expr))) + (make-instance 'simple-data-binding + :variable (make-bean-property-path-binding obj path)))) + +(defun make-bean-property-path-binding (object path) + (new "snow.binding.BeanPropertyPathBinding" + object (apply #'jvector "java.lang.String" path))) + +;;Default binding types +(defun default-data-binding-types () + (let ((ht (make-hash-table))) + (setf (gethash :simple ht) 'simple-data-binding) + (setf (gethash :bean ht) 'bean-data-binding) + ht)) + +(defparameter *binding-types* (default-data-binding-types)) + +(defun get-data-binding-class (binding-type) + (if (keywordp binding-type) + (gethash binding-type *binding-types*) + binding-type)) + +(defun make-data-binding (type &rest options) + (apply #'make-instance (get-data-binding-class type) options)) Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Mon Oct 19 17:28:31 2009 @@ -30,7 +30,7 @@ (defpackage :snow - (:use :common-lisp :java #+snow-cells :cells) + (:use :common-lisp :java :cl-utilities #+snow-cells :cells) (:shadow #+snow-cells #:dbg) (:export ;;Widgets Modified: trunk/src/lisp/snow/sexy-java.lisp ============================================================================== --- trunk/src/lisp/snow/sexy-java.lisp (original) +++ trunk/src/lisp/snow/sexy-java.lisp Mon Oct 19 17:28:31 2009 @@ -190,7 +190,10 @@ (t form))) form)) -(defun ensure-list (obj) - (if (listp obj) - obj - (list obj))) \ No newline at end of file +(defun jvector (element-type &rest args) + (let ((arr (jnew-array (jclass element-type) (length args)))) + (loop + :for x :in args + :for i := 0 :then (incf i) + :do (setf (jarray-ref arr i) x)) + arr)) \ 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 Mon Oct 19 17:28:31 2009 @@ -31,8 +31,8 @@ ;;Core stuff + cells if needed (asdf:defsystem :snow :serial t - :version "0.1" - :depends-on (#+snow-cells :cells) + :version "0.2" + :depends-on (:cl-utilities #+snow-cells :cells) :components ((:file "packages") (:file "sexy-java") (:file "utils") Modified: trunk/src/lisp/snow/utils.lisp ============================================================================== --- trunk/src/lisp/snow/utils.lisp (original) +++ trunk/src/lisp/snow/utils.lisp Mon Oct 19 17:28:31 2009 @@ -32,13 +32,13 @@ (in-package :snow) ;;Some utilities... -(defmacro with-unique-names ((&rest bindings) &body body) +#|(defmacro with-unique-names ((&rest bindings) &body body) `(let ,(mapcar #'(lambda (binding) (destructuring-bind (var prefix) (if (consp binding) binding (list binding binding)) `(,var (gensym ,(string prefix))))) bindings) - , at body)) + , at body))|# #|(defmacro with-captured-specials ((&rest specials) &body body) (with-unique-names (tmp) From astalla at common-lisp.net Tue Oct 20 18:24:44 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 20 Oct 2009 14:24:44 -0400 Subject: [snow-cvs] r7 - in trunk: src/java/snow/binding test/src/snow Message-ID: Author: astalla Date: Tue Oct 20 14:24:43 2009 New Revision: 7 Log: Fixed BeanPropertyPathBinding Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java trunk/test/src/snow/BindingTest.java Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java ============================================================================== --- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original) +++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Tue Oct 20 14:24:43 2009 @@ -82,9 +82,10 @@ reader = pd.getReadMethod(); writer = pd.getWriteMethod(); if(nextPropertyPath.length > 0) { - Object subObj = getValue(); + Object subObj = getLocalValue(); if(subObj != null) { nextListener = new BeanPropertyPathBinding(subObj, nextPropertyPath, this); + } } } @@ -137,20 +138,66 @@ fireValueChange(evt.getOldValue(), evt.getNewValue(), false); } } + + private BeanPropertyPathBinding getTarget() { + if(nextPropertyPath.length == 0) { + return this; + } else if(nextListener != null) { + return nextListener.getTarget(); + } else { + return null; + } + } + public Object getLocalValue() { + try { + return reader.invoke(object); + } catch(Exception e) { + throw new RuntimeException(e); + } + } + @Override public Object getValue() { try { - return reader.invoke(object); + BeanPropertyPathBinding target = getTarget(); + if(target != null) { + return target.getLocalValue(); + } else { + return null; + } + } catch(Exception e) { + throw new RuntimeException(e); + } + } + + public void setLocalValue(Object value) { + try { + System.err.println(object + " " + writer + " " + value); + writer.invoke(object, value); } catch(Exception e) { throw new RuntimeException(e); } } + @Override public void setValue(Object value) { try { - writer.invoke(object, value); + BeanPropertyPathBinding target = getTarget(); + if(target != null) { + target.setLocalValue(value); + } else { + StringBuilder sb = new StringBuilder(); + assert(nextPropertyPath != null); + for(String s : nextPropertyPath) { + if(sb.length() > 0) { + sb.append('.'); + } + sb.append(s); + } + throw new NullPointerException("Property " + sb + " not reachable."); + } } catch(Exception e) { throw new RuntimeException(e); } Modified: trunk/test/src/snow/BindingTest.java ============================================================================== --- trunk/test/src/snow/BindingTest.java (original) +++ trunk/test/src/snow/BindingTest.java Tue Oct 20 14:24:43 2009 @@ -11,6 +11,7 @@ import net.miginfocom.swing.MigLayout; import org.junit.*; +import static org.junit.Assert.*; import com.jgoodies.binding.adapter.Bindings; import com.jgoodies.binding.beans.Model; @@ -67,13 +68,17 @@ }); bean.getBean().setProperty("value2"); if(flag[0]) { - Assert.fail("value was set but listener not fired"); + Assert.fail("value was set but listener didn't fire"); } flag[0] = true; bean.getBean().setProperty("value2"); if(!flag[0]) { Assert.fail("value was set to same value and listener fired"); } + model.setValue("42"); + System.err.println("outer bean: " + bean); + System.err.println("inner bean: " + bean.getBean()); + assertEquals("42", bean.getBean().getProperty()); } public static void main(String[] args) { From astalla at common-lisp.net Tue Oct 20 18:26:56 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 20 Oct 2009 14:26:56 -0400 Subject: [snow-cvs] r8 - in trunk: src/java/snow/binding test/src/snow Message-ID: Author: astalla Date: Tue Oct 20 14:26:55 2009 New Revision: 8 Log: Removed debug print statements. Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java trunk/test/src/snow/BindingTest.java Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java ============================================================================== --- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original) +++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Tue Oct 20 14:26:55 2009 @@ -173,7 +173,6 @@ public void setLocalValue(Object value) { try { - System.err.println(object + " " + writer + " " + value); writer.invoke(object, value); } catch(Exception e) { throw new RuntimeException(e); Modified: trunk/test/src/snow/BindingTest.java ============================================================================== --- trunk/test/src/snow/BindingTest.java (original) +++ trunk/test/src/snow/BindingTest.java Tue Oct 20 14:26:55 2009 @@ -76,8 +76,6 @@ Assert.fail("value was set to same value and listener fired"); } model.setValue("42"); - System.err.println("outer bean: " + bean); - System.err.println("inner bean: " + bean.getBean()); assertEquals("42", bean.getBean().getProperty()); } From astalla at common-lisp.net Tue Oct 20 22:09:46 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 20 Oct 2009 18:09:46 -0400 Subject: [snow-cvs] r9 - in trunk: src/java/snow/example src/lisp/snow test/src/snow Message-ID: Author: astalla Date: Tue Oct 20 18:09:45 2009 New Revision: 9 Log: Added EL to example (no reader macro yet), updated binding test Modified: trunk/src/java/snow/example/SnowExample.java trunk/src/java/snow/example/example.lisp trunk/src/lisp/snow/data-binding.lisp trunk/test/src/snow/BindingTest.java Modified: trunk/src/java/snow/example/SnowExample.java ============================================================================== --- trunk/src/java/snow/example/SnowExample.java (original) +++ trunk/src/java/snow/example/SnowExample.java Tue Oct 20 18:09:45 2009 @@ -34,4 +34,13 @@ firePropertyChange("property1", oldValue, property1); } + private SnowExample nested = null; + + public SnowExample getNested() { + if(nested == null) { + nested = new SnowExample(); + } + return nested; + } + } Modified: trunk/src/java/snow/example/example.lisp ============================================================================== --- trunk/src/java/snow/example/example.lisp (original) +++ trunk/src/java/snow/example/example.lisp Tue Oct 20 18:09:45 2009 @@ -7,6 +7,9 @@ (defvar *object* (new "snow.example.SnowExample")) (defvar *variable* (make-var "42")) (defvar *cells-object* (make-instance 'my-model)) +(setq *bean-factory* #'(lambda (x) ;dummy + (declare (ignore x)) + *object*)) (with-gui (:swing) (let ((myframe @@ -26,18 +29,35 @@ :layout (jfield "java.awt.BorderLayout" "EAST"))) (scroll () (panel () - (label :binding (make-bean-binding *object* "property1")) - (label :binding (make-cells-binding (c? (aaa *cells-object*)))) - (label :binding (make-cells-binding (c? (bbb *cells-object*)))) - (label :binding (make-simple-binding *variable*)) + (label :text "bean binding") + (label :binding (make-bean-data-binding *object* "property1") + :layout "wrap") + (label :text "EL binding") + (label :binding (make-el-data-binding "bean.nested.property1") + :layout "wrap") + (label :text "cells bindings: aaa and bbb") + (label :binding (make-cells-data-binding (c? (aaa *cells-object*)))) + (label :binding (make-cells-data-binding (c? (bbb *cells-object*))) + :layout "wrap") + (label :text "simple binding to a variable") + (label :binding (make-simple-data-binding *variable*) + :layout "wrap") (button :text "another one" :layout "wrap") - (text-field :binding (make-bean-binding *object* "property1") - :layout "growx") + (label :text "set property1") + (text-field :binding (make-bean-data-binding *object* "property1") + :layout "growx, wrap") + (label :text "set nested.property1") + (text-field :binding (make-el-data-binding "bean.nested.property1") + :layout "growx, wrap") (button :text "Test!" :layout "wrap" :on-action (lambda (event) (setf (jproperty-value *object* "property1") "Test property") + (setf (jproperty-value + (jproperty-value *object* "nested") + "property1") + "Nested property") (setf (var *variable*) "Test var") (setf (aaa *cells-object*) "Test cell")))))))) (pack myframe))) @@ -49,13 +69,13 @@ :on-action (lambda (event) (print "Hello, world!") (print event))) - (text-field :binding (make-bean-binding *object* "property1")) + (text-field :binding (make-bean-data-binding *object* "property1")) (text-field :binding - (make-cells-binding (c? (aaa *cells-object*)) + (make-cells-data-binding (c? (aaa *cells-object*)) #'(lambda (x) (setf (aaa *cells-object*) x)))) - (text-field :binding (make-slot-binding *cells-object* 'aaa)) - (text-field :binding (make-simple-binding *variable*) + (text-field :binding (make-slot-data-binding *cells-object* 'aaa)) + (text-field :binding (make-simple-data-binding *variable*) :layout "wrap") (label :text "haha") (panel (:layout-manager :mig :layout "grow") Modified: trunk/src/lisp/snow/data-binding.lisp ============================================================================== --- trunk/src/lisp/snow/data-binding.lisp (original) +++ trunk/src/lisp/snow/data-binding.lisp Tue Oct 20 18:09:45 2009 @@ -133,14 +133,14 @@ (obj (funcall *bean-factory* (car splitted-expr))) (path (cdr splitted-expr))) (make-instance 'simple-data-binding - :variable (make-bean-property-path-binding obj path)))) + :variable (new "snow.binding.BeanPropertyPathBinding" + obj (apply #'jvector "java.lang.String" path))))) -(defun make-bean-property-path-binding (object path) - (new "snow.binding.BeanPropertyPathBinding" - object (apply #'jvector "java.lang.String" path))) +;(defun make-bean-property-path-data-binding (object path) +;) ;;Default binding types -(defun default-data-binding-types () +#|(defun default-data-binding-types () (let ((ht (make-hash-table))) (setf (gethash :simple ht) 'simple-data-binding) (setf (gethash :bean ht) 'bean-data-binding) @@ -155,3 +155,4 @@ (defun make-data-binding (type &rest options) (apply #'make-instance (get-data-binding-class type) options)) +|# \ No newline at end of file Modified: trunk/test/src/snow/BindingTest.java ============================================================================== --- trunk/test/src/snow/BindingTest.java (original) +++ trunk/test/src/snow/BindingTest.java Tue Oct 20 18:09:45 2009 @@ -68,12 +68,12 @@ }); bean.getBean().setProperty("value2"); if(flag[0]) { - Assert.fail("value was set but listener didn't fire"); + fail("value was set but listener didn't fire"); } flag[0] = true; bean.getBean().setProperty("value2"); if(!flag[0]) { - Assert.fail("value was set to same value and listener fired"); + fail("value was set to same value and listener fired"); } model.setValue("42"); assertEquals("42", bean.getBean().getProperty()); From astalla at common-lisp.net Thu Oct 22 20:10:11 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 22 Oct 2009 16:10:11 -0400 Subject: [snow-cvs] r10 - in trunk: lib lib/named-readtables lib/named-readtables/doc lib/named-readtables/tests src/java/snow src/java/snow/example src/lisp/snow Message-ID: Author: astalla Date: Thu Oct 22 16:10:10 2009 New Revision: 10 Log: Integrated named readtables updated to latest abcl (fixes a bug with set-syntax-from-char which broke named readtables) implemented read macro for EL binding fixed compilation with ant (snow is no longer an eclipse project) Added: trunk/lib/named-readtables/ trunk/lib/named-readtables/LICENSE trunk/lib/named-readtables/cruft.lisp trunk/lib/named-readtables/define-api.lisp trunk/lib/named-readtables/doc/ trunk/lib/named-readtables/doc/named-readtables.html trunk/lib/named-readtables/named-readtables.asd trunk/lib/named-readtables/named-readtables.lisp trunk/lib/named-readtables/package.lisp trunk/lib/named-readtables/tests/ trunk/lib/named-readtables/tests/package.lisp trunk/lib/named-readtables/tests/rt.lisp trunk/lib/named-readtables/tests/tests.lisp trunk/lib/named-readtables/utils.lisp Modified: trunk/lib/abcl.jar trunk/src/java/snow/Snow.java trunk/src/java/snow/example/example.lisp trunk/src/lisp/snow/compile-system.lisp trunk/src/lisp/snow/data-binding.lisp trunk/src/lisp/snow/packages.lisp trunk/src/lisp/snow/snow.asd Modified: trunk/lib/abcl.jar ============================================================================== Binary files. No diff available. Added: trunk/lib/named-readtables/LICENSE ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/LICENSE Thu Oct 22 16:10:10 2009 @@ -0,0 +1,36 @@ + +Copyright (c) 2007 - 2009 Tobias C. Rittweiler +Copyright (c) 2007, Robert P. Goldman and SIFT, LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the names of Tobias C. Rittweiler, Robert P. Goldman, + SIFT, LLC nor the names of its contributors may be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert +P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert +P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: trunk/lib/named-readtables/cruft.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/cruft.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,375 @@ +;;;; +;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler +;;;; +;;;; All rights reserved. +;;;; +;;;; See LICENSE for details. +;;;; + +(in-package :editor-hints.named-readtables) + +(defmacro define-cruft (name lambda-list &body (docstring . alternatives)) + (assert (typep docstring 'string) (docstring) "Docstring missing!") + (assert (not (null alternatives))) + `(progn + (declaim (inline ,name)) + (defun ,name ,lambda-list ,docstring ,(first alternatives)))) + +(eval-when (:compile-toplevel :execute) + #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE" + (find-package "SB-IMPL")) + (pushnew :sbcl+safe-standard-readtable *features*))) + + +;;;;; Implementation-dependent cruft + +;;;; Mapping between a readtable object and its readtable-name. + +(defvar *readtable-names* (make-hash-table :test 'eq)) + +(define-cruft %associate-readtable-with-name (name readtable) + "Associate READTABLE with NAME for READTABLE-NAME to work." + #+ :common-lisp (setf (gethash readtable *readtable-names*) name)) + +(define-cruft %unassociate-readtable-from-name (name readtable) + "Remove the association between READTABLE and NAME." + #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*))) + (remhash readtable *readtable-names*))) + +(define-cruft %readtable-name (readtable) + "Return the name associated with READTABLE." + #+ :common-lisp (values (gethash readtable *readtable-names*))) + +(define-cruft %list-all-readtable-names () + "Return a list of all available readtable names." + #+ :common-lisp (list* :standard :current + (loop for name being each hash-value of *readtable-names* + collect name))) + + +;;;; Mapping between a readtable-name and the actual readtable object. + +;;; On Allegro we reuse their named-readtable support so we work +;;; nicely on their infrastructure. + +#-allegro +(defvar *named-readtables* (make-hash-table :test 'eq)) + +#+allegro +(defun readtable-name-for-allegro (symbol) + (multiple-value-bind (kwd status) + (if (keywordp symbol) + (values symbol nil) + ;; Kludge: ACL uses keywords to name readtables, we allow + ;; arbitrary symbols. + (intern (format nil "~A.~A" + (package-name (symbol-package symbol)) + (symbol-name symbol)) + :keyword)) + (prog1 kwd + (assert (or (not status) (get kwd 'named-readtable-designator))) + (setf (get kwd 'named-readtable-designator) t)))) + +(define-cruft %associate-name-with-readtable (name readtable) + "Associate NAME with READTABLE for FIND-READTABLE to work." + #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable) + #+ :common-lisp (setf (gethash name *named-readtables*) readtable)) + +(define-cruft %unassociate-name-from-readtable (name readtable) + "Remove the association between NAME and READTABLE" + #+ :allegro (let ((n (readtable-name-for-allegro name))) + (assert (eq readtable (excl:named-readtable n))) + (setf (excl:named-readtable n) nil)) + #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*))) + (remhash name *named-readtables*))) + +(define-cruft %find-readtable (name) + "Return the readtable named NAME." + #+ :allegro (excl:named-readtable (readtable-name-for-allegro name)) + #+ :common-lisp (values (gethash name *named-readtables* nil))) + + +;;;; Reader-macro related predicates + +;;; CLISP creates new function objects for standard reader macros on +;;; each readtable copy. +(define-cruft function= (fn1 fn2) + "Are reader-macro function-designators FN1 and FN2 the same?" + #+ :clisp + (let* ((fn1 (ensure-function fn1)) + (fn2 (ensure-function fn2)) + (n1 (system::function-name fn1)) + (n2 (system::function-name fn2))) + (if (and (eq n1 :lambda) (eq n2 :lambda)) + (eq fn1 fn2) + (equal n1 n2))) + #+ :common-lisp + (eq (ensure-function fn1) (ensure-function fn2))) + +;;; CCL has a bug that prevents the portable form below from working +;;; (Ticket 601). CLISP will incorrectly fold the call to G-D-M-C away +;;; if not declared inline. +(define-cruft dispatch-macro-char-p (char rt) + "Is CHAR a dispatch macro character in RT?" + #+ :ccl + (let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt))))) + (or (consp (cdr def)) + (eq (car def) #'ccl::read-dispatch))) + #+ :common-lisp + (handler-case (locally + #+clisp (declare (notinline get-dispatch-macro-character)) + (get-dispatch-macro-character char #\x rt) + t) + (error () nil))) + +;; (defun macro-char-p (char rt) +;; (let ((reader-fn (%get-macro-character char rt))) +;; (and reader-fn t))) + +;; (defun standard-macro-char-p (char rt) +;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt) +;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*) +;; (and (eq rt-fn std-fn) +;; (eq rt-flag std-flag))))) + +;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt) +;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt)))) +;; (and (eq (non-terminating-p disp-char rt) +;; (non-terminating-p disp-char *standard-readtable*)) +;; (eq (get-dispatch-macro-character disp-char sub-char rt) +;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*))))) + + +;;;; Readtables Iterators + +(defmacro with-readtable-iterator ((name readtable) &body body) + (let ((it (gensym))) + `(let ((,it (%make-readtable-iterator ,readtable))) + (macrolet ((,name () `(funcall ,',it))) + , at body)))) + +#+sbcl +(defun %make-readtable-iterator (readtable) + (let ((char-macro-array (sb-impl::character-macro-array readtable)) + (char-macro-ht (sb-impl::character-macro-hash-table readtable)) + (dispatch-tables (sb-impl::dispatch-tables readtable)) + (char-code 0)) + (with-hash-table-iterator (ht-iterator char-macro-ht) + (labels ((grovel-base-chars () + (declare (optimize sb-c::merge-tail-calls)) + (if (>= char-code sb-int:base-char-code-limit) + (grovel-unicode-chars) + (let ((reader-fn (svref char-macro-array char-code)) + (char (code-char (shiftf char-code (1+ char-code))))) + (if reader-fn + (yield char reader-fn) + (grovel-base-chars))))) + (grovel-unicode-chars () + (multiple-value-bind (more? char reader-fn) (ht-iterator) + (if (not more?) + (values nil nil nil nil nil) + (yield char reader-fn)))) + (yield (char reader-fn) + (let ((disp-ht)) + (cond + ((setq disp-ht (cdr (assoc char dispatch-tables))) + (let* ((disp-fn (get-macro-character char readtable)) + (sub-char-alist)) + (maphash (lambda (k v) + (push (cons k v) sub-char-alist)) + disp-ht) + (values t char disp-fn t sub-char-alist))) + (t + (values t char reader-fn nil nil)))))) + #'grovel-base-chars)))) + +#+clozure +(defun %make-readtable-iterator (readtable) + (let ((char-macro-alist (ccl::rdtab.alist readtable))) + (lambda () + (if char-macro-alist + (destructuring-bind (char . defn) (pop char-macro-alist) + (if (consp defn) + (values t char (car defn) t (cdr defn)) + (values t char defn nil nil))) + (values nil nil nil nil nil))))) + +;;; Written on ACL 8.0. +#+allegro +(defun %make-readtable-iterator (readtable) + (declare (optimize speed)) ; for TCO + (check-type readtable readtable) + (let* ((macro-table (first (excl::readtable-macro-table readtable))) + (dispatch-tables (excl::readtable-dispatch-tables readtable)) + (table-length (length macro-table)) + (idx 0)) + (labels ((grovel-macro-chars () + (if (>= idx table-length) + (grovel-dispatch-chars) + (let ((read-fn (svref macro-table idx)) + (oidx idx)) + (incf idx) + (if (or (eq read-fn #'excl::read-token) + (eq read-fn #'excl::read-dispatch-char) + (eq read-fn #'excl::undefined-macro-char)) + (grovel-macro-chars) + (values t (code-char oidx) read-fn nil nil))))) + (grovel-dispatch-chars () + (if (null dispatch-tables) + (values nil nil nil nil nil) + (destructuring-bind (disp-char sub-char-table) + (first dispatch-tables) + (setf dispatch-tables (rest dispatch-tables)) + ;;; Kludge. We can't fully clear dispatch tables + ;;; in %CLEAR-READTABLE. + (when (eq (svref macro-table (char-code disp-char)) + #'excl::read-dispatch-char) + (values t + disp-char + (svref macro-table (char-code disp-char)) + t + (loop for subch-fn across sub-char-table + for subch-code from 0 + when subch-fn + collect (cons (code-char subch-code) + subch-fn)))))))) + #'grovel-macro-chars))) + + +#-(or sbcl clozure allegro) +(eval-when (:compile-toplevel) + (let ((*print-pretty* t)) + (simple-style-warn + "~&~@< ~@;~A has not been ported to ~A. ~ + We fall back to a portable implementation of readtable iterators. ~ + This implementation has to grovel through all available characters. ~ + On Unicode-aware implementations this may come with some costs.~@:>" + (package-name '#.*package*) (lisp-implementation-type)))) + +#-(or sbcl clozure allegro) +(defun %make-readtable-iterator (readtable) + (check-type readtable readtable) + (let ((char-code 0)) + #'(lambda () + (prog () + :GROVEL + (when (< char-code char-code-limit) + (let* ((char (code-char char-code)) + (fn (get-macro-character char readtable))) + (incf char-code) + (when (not fn) (go :GROVEL)) + (multiple-value-bind (disp? alist) + (handler-case ; grovel dispatch macro characters. + (values t + ;; Only grovel upper case characters to + ;; avoid duplicates. + (loop for code from 0 below char-code-limit + for subchar = (let ((ch (code-char code))) + (when (or (not (alpha-char-p ch)) + (upper-case-p ch)) + ch)) + for disp-fn = (and subchar + (get-dispatch-macro-character + char subchar readtable)) + when disp-fn + collect (cons subchar disp-fn))) + (error () nil)) + (return (values t char fn disp? alist))))))))) + +(defmacro do-readtable ((entry-designator readtable &optional result) + &body body) + "Iterate through a readtable's macro characters, and dispatch macro characters." + (destructuring-bind (char &optional reader-fn non-terminating-p disp? table) + (if (symbolp entry-designator) + (list entry-designator) + entry-designator) + (let ((iter (gensym "ITER+")) + (more? (gensym "MORE?+")) + (rt (gensym "READTABLE+"))) + `(let ((,rt ,readtable)) + (with-readtable-iterator (,iter ,rt) + (loop + (multiple-value-bind (,more? + ,char + ,@(when reader-fn (list reader-fn)) + ,@(when disp? (list disp?)) + ,@(when table (list table))) + (,iter) + (unless ,more? (return ,result)) + (let ,(when non-terminating-p + ;; FIXME: N-T-P should be incorporated in iterators. + `((,non-terminating-p + (nth-value 1 (get-macro-character ,char ,rt))))) + , at body)))))))) + +;;;; Misc + +;;; This should return an implementation's actual standard readtable +;;; object only if the implementation makes the effort to guard against +;;; modification of that object. Otherwise it should better return a +;;; copy. +(define-cruft %standard-readtable () + "Return the standard readtable." + #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable* + #+ :common-lisp (copy-readtable nil)) + +;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a +;;; readtable's dispatch table properly. +;;; Same goes for Allegro but that does not seem to provide a +;;; setter for their readtable's dispatch tables. Hence this ugly +;;; workaround. +(define-cruft %clear-readtable (readtable) + "Make all macro characters in READTABLE be constituents." + #+ :sbcl + (prog1 readtable + (do-readtable (char readtable) + (set-syntax-from-char char #\A readtable)) + (setf (sb-impl::dispatch-tables readtable) nil)) + #+ :allegro + (prog1 readtable + (do-readtable (char readtable) + (set-syntax-from-char char #\A readtable)) + (let ((dispatch-tables (excl::readtable-dispatch-tables readtable))) + (setf (cdr dispatch-tables) nil) + (setf (caar dispatch-tables) #\Backspace) + (setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil)))) + #+ :common-lisp + (do-readtable (char readtable readtable) + (set-syntax-from-char char #\A readtable))) + +;;; See Clozure Trac Ticket 601. This is supposed to be removed at +;;; some point in the future. +(define-cruft %get-dispatch-macro-character (char subchar rt) + "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER." + #+ :ccl (ignore-errors + (get-dispatch-macro-character char subchar rt)) + #+ :common-lisp (get-dispatch-macro-character char subchar rt)) + +;;; Allegro stores READ-TOKEN as reader macro function of each +;;; constituent character. +(define-cruft %get-macro-character (char rt) + "Ensure ANSI behaviour for GET-MACRO-CHARACTER." + #+ :allegro (let ((fn (get-macro-character char rt))) + (cond ((not fn) nil) + ((function= fn #'excl::read-token) nil) + (t fn))) + #+ :common-lisp (get-macro-character char rt)) + + +;;;; Specialized PRINT-OBJECT for named readtables. + +;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT +;;; that specializes on READTABLE is actually forbidden. It's quite +;;; likely to work (modulo package-locks) on most implementations, +;;; though. + +;;; We don't need this on Allegro CL's as we hook into their +;;; named-readtable facility, and they provide such a method already. +#-allegro +(without-package-lock (:common-lisp) + (defmethod print-object :around ((rt readtable) stream) + (let ((name (readtable-name rt))) + (if name + (print-unreadable-object (rt stream :type nil :identity t) + (format stream "~A ~S" :named-readtable name)) + (call-next-method))))) \ No newline at end of file Added: trunk/lib/named-readtables/define-api.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/define-api.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,63 @@ + +(in-package :named-readtables) + +(defmacro define-api (name lambda-list type-list &body body) + (flet ((parse-type-list (type-list) + (let ((pos (position '=> type-list))) + (assert pos () "You forgot to specify return type (`=>' missing.)") + (values (subseq type-list 0 pos) + `(values ,@(nthcdr (1+ pos) type-list) &optional))))) + (multiple-value-bind (body decls docstring) + (parse-body body :documentation t :whole `(define-api ,name)) + (multiple-value-bind (arg-typespec value-typespec) + (parse-type-list type-list) + (multiple-value-bind (reqs opts rest keys) + (parse-ordinary-lambda-list lambda-list) + (declare (ignorable reqs opts rest keys)) + `(progn + (declaim (ftype (function ,arg-typespec ,value-typespec) ,name)) + (locally + ;;; Muffle the annoying "&OPTIONAL and &KEY found in + ;;; the same lambda list" style-warning + #+sbcl (declare (sb-ext:muffle-conditions style-warning)) + (defun ,name ,lambda-list + ,docstring + + #+sbcl (declare (sb-ext:unmuffle-conditions style-warning)) + + , at decls + + ;; SBCL will interpret the ftype declaration as + ;; assertion and will insert type checks for us. + #-sbcl + (progn + ;; CHECK-TYPE required parameters + ,@(loop for req-arg in reqs + for req-type = (pop type-list) + do (assert req-type) + collect `(check-type ,req-arg ,req-type)) + + ;; CHECK-TYPE optional parameters + ,@(loop initially (assert (or (null opts) + (eq (pop type-list) '&optional))) + for (opt-arg . nil) in opts + for opt-type = (pop type-list) + do (assert opt-type) + collect `(check-type ,opt-arg ,opt-type)) + + ;; CHECK-TYPE rest parameter + ,@(when rest + (assert (eq (pop type-list) '&rest)) + (let ((rest-type (pop type-list))) + (assert rest-type) + `((dolist (x ,rest) + (check-type x ,rest-type))))) + + ;; CHECK-TYPE key parameters + ,@(loop initially (assert (or (null keys) + (eq (pop type-list) '&key))) + for ((keyword key-arg) . nil) in keys + for (nil key-type) = (find keyword type-list :key #'car) + collect `(check-type ,key-arg ,key-type))) + + , at body)))))))) \ No newline at end of file Added: trunk/lib/named-readtables/doc/named-readtables.html ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/doc/named-readtables.html Thu Oct 22 16:10:10 2009 @@ -0,0 +1,463 @@ + + + + + + EDITOR-HINTS.NAMED-READTABLES + + + + + +

EDITOR-HINTS.NAMED-READTABLES

+ +
     by Tobias C Rittweiler
+ +Download:
 
+ +      + darcs get http://common-lisp.net/~trittweiler/darcs/editor-hints/named-readtables/ (to be changed) + +
 

Contents

+
    +
  1. What are Named-Readtables? +
  2. Notes on the API +
  3. Important API idiosyncrasies +
  4. Preregistered Readtables +
  5. Examples +
  6. Acknowledgements + + +
  7. Dictionary +
      +
    1. COPY-NAMED-READTABLE +
    2. DEFREADTABLE +
    3. ENSURE-READTABLE +
    4. FIND-READTABLE +
    5. IN-READTABLE +
    6. LIST-ALL-NAMED-READTABLES +
    7. MAKE-READTABLE +
    8. MERGE-READTABLES-INTO +
    9. NAMED-READTABLE-DESIGNATOR +
    10. READER-MACRO-CONFLICT +
    11. READTABLE-DOES-ALREADY-EXIST +
    12. READTABLE-DOES-NOT-EXIST +
    13. READTABLE-NAME +
    14. REGISTER-READTABLE +
    15. RENAME-READTABLE +
    16. UNREGISTER-READTABLE + +
    +

 

What are Named-Readtables?

+    Named-Readtables is a library that provides a namespace for readtables akin to the
    already-existing namespace of packages. In particular: +
    +          
  • you can associate readtables with names, and retrieve readtables by names;
    • +          
  • you can associate source files with readtable names, and be sure that the
    right readtable is active when compiling/loading the file;
    • +          
  • similiarly, your development environment now has a chance to automatically
    determine what readtable should be active while processing source forms on
    interactive commands. (E.g. think of `C-c C-c' in Slime [yet to be done])
    • +
+    Additionally, it also attempts to become a facility for using readtables in a
    modular way. In particular: +
    +          
  • it provides a macro to specify the content of a readtable at a glance;
    • +          
  • it makes it possible to use multiple inheritance between readtables.
    • +
+
 

Notes on the API

+    The API heavily imitates the API of packages. This has the nice property that any
    experienced Common Lisper will take it up without effort. +

+            DEFREADTABLE - DEFPACKAGE +

+            IN-READTABLE - IN-PACKAGE +

+            MERGE-READTABLES-INTO - USE-PACKAGE +

+            MAKE-READTABLE - MAKE-PACKAGE +

+            UNREGISTER-READTABLE - DELETE-PACKAGE +

+            RENAME-READTABLE - RENAME-PACKAGE +

+            FIND-READTABLE - FIND-PACKAGE +

+            READTABLE-NAME - PACKAGE-NAME +

+            LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES +
 

Important API idiosyncrasies

+    There are three major differences between the API of Named-Readtables, and the API
    of packages. +

+      1. Readtable names are symbols not strings. +

+                Time has shown that the fact that packages are named by strings causes severe
                headache because of the potential of package names colliding with each other. +

+                Hence, readtables are named by symbols lest to make the situation worse than it
                already is. Consequently, readtables named CL-ORACLE:SQL-SYNTAX and
                CL-MYSQL:SQL-SYNTAX can happily coexist next to each other. Or, taken to an extreme,
                SCHEME:SYNTAX and ELISP:SYNTAX. +

+                If, for example to duly signify the importance of your cool readtable hack, you
                really think it deserves a global name, you can always resort to keywords. +

+      2. The inheritance is resolved statically, not dynamically. +

+                A package that uses another package will have access to all the other
                package's exported symbols, even to those that will be added after its
                definition. I.e. the inheritance is resolved at run-time, that is dynamically. +

+                Unfortunately, we cannot do the same for readtables in a portable manner. +

+                Therefore, we do not talk about "using" another readtable but about
                "merging" the other readtable's definition into the readtable we are
                going to define. I.e. the inheritance is resolved once at definition time, that is
                statically. +

+                (Such merging can more or less be implemented portably albeit at a certain cost.
                Most of the time, this cost manifests itself at the time a readtable is defined,
                i.e. once at compile-time, so it may not bother you. Nonetheless, we provide extra
                support for Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your
                implementation of choice are welcome, of course.) +

+      3. DEFREADTABLE does not have compile-time effects. +

+                If you define a package via DEFPACKAGE, you can make that package the currently
                active package for the subsequent compilation of the same file via IN-PACKAGE. The
                same is, however, not true for DEFREADTABLE and IN-READTABLE for the following
                reason: +

+                It's unlikely that the need for special reader-macros arises for a problem
                which can be solved in just one file. Most often, you're going to define the
                reader macro functions, and set up the corresponding readtable in an extra file. +

+                If DEFREADTABLE had compile-time effects, you'd have to wrap each definition
                of a reader-macro function in an EVAL-WHEN to make its definition available at
                compile-time. Because that's simply not the common case, DEFREADTABLE does not
                have a compile-time effect. +

+                If you want to use a readtable within the same file as its definition, wrap the
                DEFREADTABLE and the reader-macro function definitions in an explicit EVAL-WHEN. +
 

Preregistered Readtables

+        - NIL, :STANDARD, and :COMMON-LISP designate the standard readtable. +

+        - :MODERN designates a case-preserving standard-readtable. +

+        - :CURRENT designates the current readtable. +
 

Examples

+
+     (defreadtable elisp:syntax
+        (:merge :standard)
+        (:macro-char #\? #'elisp::read-character-literal t)
+        (:macro-char #\[ #'elisp::read-vector-literal t)
+        ...
+        (:case :preserve))
+    
+     (defreadtable scheme:syntax
+        (:merge :standard)
+        (:macro-char #\[ #'(lambda (stream char)
+                              (read-delimited-list #\] stream)))
+        (:macro-char #\# :dispatch)
+        (:dispatch-macro-char #\# #\t #'scheme::read-#t)
+        (:dispatch-macro-char #\# #\f #'scheme::read-#f)
+        ...
+        (:case :preserve))
+    
+     (in-readtable elisp:syntax)
+    
+     ...
+    
+     (in-readtable scheme:syntax)
+    
+     ...
+
+ +
 

Acknowledgements

+    Thanks to Robert Goldman for making me want to write this library. +

+    Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart Botta, David
    Crawford, and Pascal Costanza for being early adopters, providing comments and
    bugfixes. +
 
+
 

Dictionary

+ + + + +


[Function]
copy-named-readtable named-readtable => result

  Argument and Values:

named-readtable: (OR + READTABLE + SYMBOL)
result: READTABLE
  Description: +
+ +Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument. + + +
+ + + + + + +


[Macro]
defreadtable name &body options => result

  Description: +

+ +Define a new named readtable, whose name is given by the symbol name. Or, if
a readtable is already registered under that name, redefine that one. +

+The readtable can be populated using the following options: +

+    (:MERGE readtable-designators+) +

+            Merge the readtables designated into the new readtable being defined as per
            MERGE-READTABLES-INTO. +

+            If no :MERGE clause is given, an empty readtable is used. See MAKE-READTABLE. +

+    (:FUZE readtable-designators+) +

+            Like :MERGE except: +

+            Error conditions of type READER-MACRO-CONFLICT that are signaled during the merge
            operation will be silently continued. It follows that reader macros in earlier
            entries will be overwritten by later ones. +

+    (:DISPATCH-MACRO-CHAR macro-char sub-char function) +

+            Define a new sub character sub-char for the dispatching macro character
            macro-char, per SET-DISPATCH-MACRO-CHARACTER. You probably have to define
            macro-char as a dispatching macro character by the following option first. +

+    (:MACRO-CHAR macro-char function [non-terminating-p]) +

+            Define a new macro character in the readtable, per SET-MACRO-CHARACTER. If
            function is the keyword :DISPATCH, macro-char is made a dispatching
            macro character, per MAKE-DISPATCH-MACRO-CHARACTER. +

+    (:SYNTAX-FROM from-readtable-designator from-char to-char) +

+            Set the character syntax of to-char in the readtable being defined to the
            same syntax as from-char as per SET-SYNTAX-FROM-CHAR. +

+    (:CASE case-mode) +

+            Defines the case sensitivity mode of the resulting readtable. +

+Any number of option clauses may appear. The options are grouped by their type, but
in each group the order the options appeared textually is preserved. The following
groups exist and are executed in the following order: :MERGE and :FUZE (one group),
:CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM. +

+Notes: +

+    The readtable is defined at load-time. If you want to have it available at
    compilation time -- say to use its reader-macros in the same file as its definition
    -- you have to wrap the DEFREADTABLE form in an explicit EVAL-WHEN. +

+    On redefinition, the target readtable is made empty first before it's refilled
    according to the clauses. +

+    NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are preregistered readtable
    names. + + +
+ + + + + + +


[Function]
ensure-readtable name &optional default => result

  Argument and Values:

name: (OR + READTABLE + SYMBOL)
default: (OR + READTABLE + SYMBOL)
result: READTABLE
  Description: +
+ +Looks up the readtable specified by name and returns it if it's found.
If it is not found, it registers the readtable designated by default under
the name represented by name; or if no default argument is given, it signals
an error of type READTABLE-DOES-NOT-EXIST instead. + + +
+ + + + + + +


[Function]
find-readtable name => result

  Argument and Values:

name: (OR + READTABLE + SYMBOL)
result: (OR + READTABLE + NULL)
  Description: +
+ +Looks for the readtable specified by name and returns it if it is found.
Returns NIL otherwise. + + +
+ + + + + + +


[Macro]
in-readtable name => result

  Description: +

+ +Set *READTABLE* to the readtable referred to by the symbol name. + + +
+ + + + + + +


[Function]
list-all-named-readtables => result

  Argument and Values:

result: LIST
  Description: +
+ +Returns a list of all registered readtables. The returned list is guaranteed to be
fresh, but may contain duplicates. + + +
+ + + + + + +


[Function]
make-readtable &optional name &key merge => result

  Argument and Values:

name: (OR + READTABLE + SYMBOL)
merge: LIST
result: READTABLE
  Description: +
+ +Creates and returns a new readtable under the specified name. +

+merge takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clause of DEFREADTABLE
for details.) +

+If merge is NIL, an empty readtable is used instead. +

+If name is not given, an anonymous empty readtable is returned. +

+Notes: +

+    An empty readtable is a readtable where each character's syntax is the same as
    in the standard readtable except that each macro character has been made a
    constituent. Basically: whitespace stays whitespace, everything else is constituent. + + +
+ + + + + + +


[Function]
merge-readtables-into result-readtable &rest named-readtables => result

  Argument and Values:

result-readtable: (OR + READTABLE + SYMBOL)
named-readtables: (OR + READTABLE + SYMBOL)
result: READTABLE
  Description: +
+ +Copy the contents of each readtable in named-readtables into
result-table. +

+If a macro character appears in more than one of the readtables, i.e. if a conflict
is discovered during the merge, an error of type READER-MACRO-CONFLICT is signaled. + + +
+ + + + + + +


[Type]
named-readtable-designator

  Description: +

+ +Either a symbol or a readtable itself. + + +
+ + + + + + +


[Condition type]
reader-macro-conflict

  Description: +

+ +Continuable. +

+This condition is signaled during the merge process if a) a reader macro (be it a
macro character or the sub character of a dispatch macro character) is both present
in the source as well as the target readtable, and b) if and only if the two
respective reader macro functions differ. + + +
+ + + + + + +


[Condition type]
readtable-does-already-exist

  Description: +

+ +Continuable. + + +
+ + + + + + +


[Condition type]
readtable-does-not-exist

+

+ + + +
+ + + + + + +


[Function]
readtable-name named-readtable => result

  Argument and Values:

named-readtable: (OR + READTABLE + SYMBOL)
result: SYMBOL
  Description: +
+ +Returns the name of the readtable designated by named-readtable, or NIL. + + +
+ + + + + + +


[Function]
register-readtable name readtable => result

  Argument and Values:

name: SYMBOL
readtable: READTABLE
result: READTABLE
  Description: +
+ +Associate readtable with name. Returns the readtable. + + +
+ + + + + + +


[Function]
rename-readtable old-name new-name => result

  Argument and Values:

old-name: (OR + READTABLE + SYMBOL)
new-name: SYMBOL
result: READTABLE
  Description: +
+ +Replaces the associated name of the readtable designated by old-name with
new-name. If a readtable is already registered under new-name, an
error of type READTABLE-DOES-ALREADY-EXIST is signaled. + + +
+ + + + + + +


[Function]
unregister-readtable named-readtable => result

  Argument and Values:

named-readtable: (OR + READTABLE + SYMBOL)
result: (MEMBER T + NIL)
  Description: +
+ +Remove the association of named-readtable. Returns T if successfull, NIL
otherwise. + + +
+ + + + +
+

+This documentation was generated on 2009-9-29 from a Lisp image using some home-brewn, +duct-taped,
evolutionary hacked extension of Edi Weitz' +DOCUMENTATION-TEMPLATE. +

+ + + \ No newline at end of file Added: trunk/lib/named-readtables/named-readtables.asd ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/named-readtables.asd Thu Oct 22 16:10:10 2009 @@ -0,0 +1,50 @@ +;;; -*- Mode:Lisp -*- + +(in-package :cl-user) + +(defclass asdf::named-readtables-source-file (asdf:cl-source-file) ()) + +#+sbcl +(defmethod asdf:perform :around ((o asdf:compile-op) + (c asdf::named-readtables-source-file)) + (let ((sb-ext:*derive-function-types* t)) + (call-next-method))) + + +(asdf:defsystem :named-readtables + :description "Library that creates a namespace for named readtable akin to the namespace of packages." + :author "Tobias C. Rittweiler " + :version "1.0 (unpublished so far)" + :licence "BSD" + :default-component-class asdf::named-readtables-source-file + :components + ((:file "package") + (:file "utils" :depends-on ("package")) + (:file "define-api" :depends-on ("package" "utils")) + (:file "cruft" :depends-on ("package" "utils")) + (:file "named-readtables" :depends-on ("package" "utils" "cruft" "define-api")))) + +(defmethod asdf:perform ((o asdf:test-op) + (c (eql (asdf:find-system :named-readtables)))) + (asdf:operate 'asdf:load-op :named-readtables-test) + (asdf:operate 'asdf:test-op :named-readtables-test)) + + +(asdf:defsystem :named-readtables-test + :description "Test suite for the Named-Readtables library." + :author "Tobias C. Rittweiler " + :depends-on (:named-readtables) + :components + ((:module tests + :default-component-class asdf::named-readtables-source-file + :serial t + :components + ((:file "package") + (:file "rt" :depends-on ("package")) + (:file "tests" :depends-on ("package" "rt")))))) + +(defmethod asdf:perform ((o asdf:test-op) + (c (eql (asdf:find-system + :named-readtables-test)))) + (let ((*package* (find-package :named-readtables-test))) + (funcall (intern (string '#:do-tests) *package*)))) \ No newline at end of file Added: trunk/lib/named-readtables/named-readtables.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/named-readtables.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,527 @@ +;;;; -*- Mode:Lisp -*- +;;;; +;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler +;;;; Copyright (c) 2007, Robert P. Goldman and SIFT, LLC +;;;; +;;;; All rights reserved. +;;;; +;;;; See LICENSE for details. +;;;; + +(in-package :editor-hints.named-readtables) + +;;; +;;; ``This is enough of a foothold to implement a more elaborate +;;; facility for using readtables in a localized way.'' +;;; +;;; (X3J13 Cleanup Issue IN-SYNTAX) +;;; + +;;;;;; DEFREADTABLE &c. + +(defmacro defreadtable (name &body options) + "Define a new named readtable, whose name is given by the symbol `name'. +Or, if a readtable is already registered under that name, redefine that +one. + +The readtable can be populated using the following `options': + + (:MERGE `readtable-designators'+) + + Merge the readtables designated into the new readtable being defined + as per MERGE-READTABLES-INTO. + + If no :MERGE clause is given, an empty readtable is used. See + MAKE-READTABLE. + + (:FUZE `readtable-designators'+) + + Like :MERGE except: + + Error conditions of type READER-MACRO-CONFLICT that are signaled + during the merge operation will be silently _continued_. It follows + that reader macros in earlier entries will be overwritten by later + ones. + + (:DISPATCH-MACRO-CHAR `macro-char' `sub-char' `function') + + Define a new sub character `sub-char' for the dispatching macro + character `macro-char', per SET-DISPATCH-MACRO-CHARACTER. You + probably have to define `macro-char' as a dispatching macro character + by the following option first. + + (:MACRO-CHAR `macro-char' `function' [`non-terminating-p']) + + Define a new macro character in the readtable, per SET-MACRO-CHARACTER. + If `function' is the keyword :DISPATCH, `macro-char' is made a + dispatching macro character, per MAKE-DISPATCH-MACRO-CHARACTER. + + (:SYNTAX-FROM `from-readtable-designator' `from-char' `to-char') + + Set the character syntax of `to-char' in the readtable being defined + to the same syntax as `from-char' as per SET-SYNTAX-FROM-CHAR. + + (:CASE `case-mode') + + Defines the /case sensitivity mode/ of the resulting readtable. + +Any number of option clauses may appear. The options are grouped by their +type, but in each group the order the options appeared textually is +preserved. The following groups exist and are executed in the following +order: :MERGE and :FUZE (one group), :CASE, :MACRO-CHAR +and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM. + +Notes: + + The readtable is defined at load-time. If you want to have it available + at compilation time -- say to use its reader-macros in the same file as + its definition -- you have to wrap the DEFREADTABLE form in an explicit + EVAL-WHEN. + + On redefinition, the target readtable is made empty first before it's + refilled according to the clauses. + + NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are + preregistered readtable names. +" + (check-type name symbol) + (when (reserved-readtable-name-p name) + (error "~A is the designator for a predefined readtable. ~ + Not acceptable as a user-specified readtable name." name)) + (flet ((process-option (option var) + (destructure-case option + ((:merge &rest readtable-designators) + `(merge-readtables-into ,var + ,@(mapcar #'(lambda (x) `',x) readtable-designators))) ; quotify + ((:fuze &rest readtable-designators) + `(handler-bind ((reader-macro-conflict #'continue)) + (merge-readtables-into ,var + ,@(mapcar #'(lambda (x) `',x) readtable-designators)))) + ((:dispatch-macro-char disp-char sub-char function) + `(set-dispatch-macro-character ,disp-char ,sub-char ,function ,var)) + ((:macro-char char function &optional non-terminating-p) + (if (eq function :dispatch) + `(make-dispatch-macro-character ,char ,non-terminating-p ,var) + `(set-macro-character ,char ,function ,non-terminating-p ,var))) + ((:syntax-from from-rt-designator from-char to-char) + `(set-syntax-from-char ,to-char ,from-char + ,var (find-readtable ,from-rt-designator))) + ((:case mode) + `(setf (readtable-case ,var) ,mode)))) + (remove-clauses (clauses options) + (setq clauses (if (listp clauses) clauses (list clauses))) + (remove-if-not #'(lambda (x) (member x clauses)) + options :key #'first))) + (let* ((merge-clauses (remove-clauses '(:merge :fuze) options)) + (case-clauses (remove-clauses :case options)) + (macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char) + options)) + (syntax-clauses (remove-clauses :syntax-from options)) + (other-clauses (set-difference options + (append merge-clauses case-clauses + macro-clauses syntax-clauses)))) + (cond + ((not (null other-clauses)) + (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses)) + (t + `(eval-when (:load-toplevel :execute) + ;; The (FIND-READTABLE ...) isqrt important for proper + ;; redefinition semantics, as redefining has to modify the + ;; already existing readtable object. + (let ((readtable (find-readtable ',name))) + (cond ((not readtable) + (setq readtable (make-readtable ',name))) + (t + (setq readtable (%clear-readtable readtable)) + (simple-style-warn "Overwriting already existing readtable ~S." + readtable))) + ,@(loop for option in merge-clauses + collect (process-option option 'readtable)) + ,@(loop for option in case-clauses + collect (process-option option 'readtable)) + ,@(loop for option in macro-clauses + collect (process-option option 'readtable)) + ,@(loop for option in syntax-clauses + collect (process-option option 'readtable)) + readtable))))))) + +(defmacro in-readtable (name) + "Set *READTABLE* to the readtable referred to by the symbol `name'." + (check-type name symbol) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO* + ;; (GET-MACRO-CHARACTER #\")) + (setf *readtable* (ensure-readtable ',name)) + (when (find-package :swank) + (%frob-swank-readtable-alist *package* *readtable*)) + )) + +;;; KLUDGE: [interim solution] +;;; +;;; We need support for this in Slime itself, because we want IN-READTABLE +;;; to work on a per-file basis, and not on a per-package basis. +;;; +(defun %frob-swank-readtable-alist (package readtable) + (let ((readtable-alist (find-symbol (string '#:*readtable-alist*) + (find-package :swank)))) + (when (boundp readtable-alist) + (pushnew (cons (package-name package) readtable) + (symbol-value readtable-alist) + :test #'(lambda (entry1 entry2) + (destructuring-bind (pkg-name1 . rt1) entry1 + (destructuring-bind (pkg-name2 . rt2) entry2 + (and (string= pkg-name1 pkg-name2) + (eq rt1 rt2))))))))) + +(deftype readtable-designator () + `(or null readtable)) + +(deftype named-readtable-designator () + "Either a symbol or a readtable itself." + `(or readtable-designator symbol)) + + +(declaim (special *standard-readtable* *empty-readtable*)) + +(define-api make-readtable + (&optional (name nil name-supplied-p) &key merge) + (&optional named-readtable-designator &key (:merge list) => readtable) + "Creates and returns a new readtable under the specified `name'. + +`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the +readtables the new readtable is created from. (See the :MERGE clause of +DEFREADTABLE for details.) + +If `merge' is NIL, an empty readtable is used instead. + +If `name' is not given, an anonymous empty readtable is returned. + +Notes: + + An empty readtable is a readtable where each character's syntax is the + same as in the /standard readtable/ except that each macro character has + been made a constituent. Basically: whitespace stays whitespace, + everything else is constituent." + (cond ((not name-supplied-p) + (copy-readtable *empty-readtable*)) + ((reserved-readtable-name-p name) + (error "~A is the designator for a predefined readtable. ~ + Not acceptable as a user-specified readtable name." name)) + ((let ((rt (find-readtable name))) + (and rt (prog1 nil + (cerror "Overwrite existing entry." + 'readtable-does-already-exist :readtable-name name) + ;; Explicitly unregister to make sure that we do not hold on + ;; of any reference to RT. + (unregister-readtable rt))))) + (t (let ((result (apply #'merge-readtables-into + ;; The first readtable specified in the :merge list is + ;; taken as the basis for all subsequent (destructive!) + ;; modifications (and hence it's copied.) + (copy-readtable (if merge + (ensure-readtable (first merge)) + *empty-readtable*)) + (rest merge)))) + + (register-readtable name result))))) + +(define-api rename-readtable + (old-name new-name) + (named-readtable-designator symbol => readtable) + "Replaces the associated name of the readtable designated by `old-name' +with `new-name'. If a readtable is already registered under `new-name', an +error of type READTABLE-DOES-ALREADY-EXIST is signaled." + (when (find-readtable new-name) + (cerror "Overwrite existing entry." + 'readtable-does-already-exist :readtable-name new-name)) + (let* ((readtable (ensure-readtable old-name)) + (readtable-name (readtable-name readtable))) + ;; We use the internal functions directly to omit repeated + ;; type-checking. + (%unassociate-name-from-readtable readtable-name readtable) + (%unassociate-readtable-from-name readtable-name readtable) + (%associate-name-with-readtable new-name readtable) + (%associate-readtable-with-name new-name readtable) + readtable)) + +(define-api merge-readtables-into + (result-readtable &rest named-readtables) + (named-readtable-designator &rest named-readtable-designator => readtable) + "Copy the contents of each readtable in `named-readtables' into +`result-table'. + +If a macro character appears in more than one of the readtables, i.e. if a +conflict is discovered during the merge, an error of type +READER-MACRO-CONFLICT is signaled." + (flet ((merge-into (to from) + (do-readtable ((char reader-fn non-terminating-p disp? table) from) + (check-reader-macro-conflict from to char) + (cond ((not disp?) + (set-macro-character char reader-fn non-terminating-p to)) + (t + (ensure-dispatch-macro-character char non-terminating-p to) + (loop for (subchar . subfn) in table do + (check-reader-macro-conflict from to char subchar) + (set-dispatch-macro-character char subchar subfn to))))) + to)) + (let ((result-table (ensure-readtable result-readtable))) + (dolist (table (mapcar #'ensure-readtable named-readtables)) + (merge-into result-table table)) + result-table))) + +(defun ensure-dispatch-macro-character (char &optional non-terminating-p + (readtable *readtable*)) + (if (dispatch-macro-char-p char readtable) + t + (make-dispatch-macro-character char non-terminating-p readtable))) + +(define-api copy-named-readtable + (named-readtable) + (named-readtable-designator => readtable) + "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument." + (copy-readtable (ensure-readtable named-readtable))) + +(define-api list-all-named-readtables () (=> list) + "Returns a list of all registered readtables. The returned list is +guaranteed to be fresh, but may contain duplicates." + (mapcar #'ensure-readtable (%list-all-readtable-names))) + + +(define-condition readtable-error (error) ()) + +(define-condition readtable-does-not-exist (readtable-error) + ((readtable-name :initarg :readtable-name + :initform (required-argument) + :accessor missing-readtable-name + :type named-readtable-designator)) + (:report (lambda (condition stream) + (format stream "A readtable named ~S does not exist." + (missing-readtable-name condition))))) + +(define-condition readtable-does-already-exist (readtable-error) + ((readtable-name :initarg :readtable-name + :initform (required-argument) + :accessor existing-readtable-name + :type named-readtable-designator)) + (:report (lambda (condition stream) + (format stream "A readtable named ~S already exists." + (existing-readtable-name condition)))) + (:documentation "Continuable.")) + +(define-condition reader-macro-conflict (readtable-error) + ((macro-char + :initarg :macro-char + :initform (required-argument) + :accessor conflicting-macro-char + :type character) + (sub-char + :initarg :sub-char + :initform nil + :accessor conflicting-dispatch-sub-char + :type (or null character)) + (from-readtable + :initarg :from-readtable + :initform (required-argument) + :accessor from-readtable + :type readtable) + (to-readtable + :initarg :to-readtable + :initform (required-argument) + :accessor to-readtable + :type readtable)) + (:report + (lambda (condition stream) + (format stream "~@" + (conflicting-dispatch-sub-char condition) + (conflicting-macro-char condition) + (conflicting-dispatch-sub-char condition) + (from-readtable condition) + (to-readtable condition)))) + (:documentation "Continuable. + +This condition is signaled during the merge process if a) a reader macro +\(be it a macro character or the sub character of a dispatch macro +character\) is both present in the source as well as the target readtable, +and b) if and only if the two respective reader macro functions differ.")) + +(defun check-reader-macro-conflict (from to char &optional subchar) + (flet ((conflictp (from-fn to-fn) + (assert from-fn) ; if this fails, there's a bug in readtable iterators. + (and to-fn (not (function= to-fn from-fn))))) + (when (if subchar + (conflictp (%get-dispatch-macro-character char subchar from) + (%get-dispatch-macro-character char subchar to)) + (conflictp (%get-macro-character char from) + (%get-macro-character char to))) + (cerror (format nil "Overwrite ~@C in ~A." char to) + 'reader-macro-conflict + :from-readtable from + :to-readtable to + :macro-char char + :sub-char subchar)))) + + +;;; Although there is no way to get at the standard readtable in +;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make +;;; up the perception of its existence by interning a copy of it. +;;; +;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for +;;; +;;; (equal (readtable-name (find-readtable :standard)) "STANDARD") +;;; +;;; holding true. +;;; +;;; We, however, inherit the restriction that the :STANDARD +;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd +;;; technically be feasible (as *STANDARD-READTABLE* will contain a +;;; mutable copy of the implementation-internal standard readtable.) +;;; We cannot enforce this restriction without shadowing +;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which +;;; is out of scope of this library, though. So we just threaten +;;; with nasal demons. +;;; +(defvar *standard-readtable* + (%standard-readtable)) + +(defvar *empty-readtable* + (%clear-readtable (copy-readtable nil))) + +(defvar *case-preserving-standard-readtable* + (let ((readtable (copy-readtable nil))) + (setf (readtable-case readtable) :preserve) + readtable)) + +(defparameter *reserved-readtable-names* + '(nil :standard :common-lisp :modern :current)) + +(defun reserved-readtable-name-p (name) + (and (member name *reserved-readtable-names*) t)) + +;;; In principle, we could DEFREADTABLE some of these. But we do +;;; reserved readtable lookup seperately, since we can't register a +;;; readtable for :CURRENT anyway. + +(defun find-reserved-readtable (reserved-name) + (cond ((eq reserved-name nil) *standard-readtable*) + ((eq reserved-name :standard) *standard-readtable*) + ((eq reserved-name :common-lisp) *standard-readtable*) + ((eq reserved-name :modern) *case-preserving-standard-readtable*) + ((eq reserved-name :current) *readtable*) + (t (error "Bug: no such reserved readtable: ~S" reserved-name)))) + +(define-api find-readtable + (name) + (named-readtable-designator => (or readtable null)) + "Looks for the readtable specified by `name' and returns it if it is +found. Returns NIL otherwise." + (cond ((readtablep name) name) + ((reserved-readtable-name-p name) + (find-reserved-readtable name)) + ((%find-readtable name)))) + +;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a +;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler +;;; macros below.) +(defsetf find-readtable register-readtable) + +(define-api ensure-readtable + (name &optional (default nil default-p)) + (named-readtable-designator &optional (or named-readtable-designator null) + => readtable) + "Looks up the readtable specified by `name' and returns it if it's found. +If it is not found, it registers the readtable designated by `default' +under the name represented by `name'; or if no default argument is given, +it signals an error of type READTABLE-DOES-NOT-EXIST instead." + (cond ((find-readtable name)) + ((not default-p) + (error 'readtable-does-not-exist :readtable-name name)) + (t (setf (find-readtable name) (ensure-readtable default))))) + + +(define-api register-readtable + (name readtable) + (symbol readtable => readtable) + "Associate `readtable' with `name'. Returns the readtable." + (assert (typep name '(not (satisfies reserved-readtable-name-p)))) + (%associate-readtable-with-name name readtable) + (%associate-name-with-readtable name readtable) + readtable) + +(define-api unregister-readtable + (named-readtable) + (named-readtable-designator => boolean) + "Remove the association of `named-readtable'. Returns T if successfull, +NIL otherwise." + (let* ((readtable (find-readtable named-readtable)) + (readtable-name (and readtable (readtable-name readtable)))) + (if (not readtable-name) + nil + (prog1 t + (check-type readtable-name (not (satisfies reserved-readtable-name-p))) + (%unassociate-readtable-from-name readtable-name readtable) + (%unassociate-name-from-readtable readtable-name readtable))))) + +(define-api readtable-name + (named-readtable) + (named-readtable-designator => symbol) + "Returns the name of the readtable designated by `named-readtable', or +NIL." + (let ((readtable (ensure-readtable named-readtable))) + (cond ((%readtable-name readtable)) + ((eq readtable *readtable*) :current) + ((eq readtable *standard-readtable*) :common-lisp) + ((eq readtable *case-preserving-standard-readtable*) :modern) + (t nil)))) + + +;;;;; Compiler macros + +;;; Since the :STANDARD readtable is interned, and we can't enforce +;;; its immutability, we signal a style-warning for suspicious uses +;;; that may result in strange behaviour: + +;;; Modifying the standard readtable would, obviously, lead to a +;;; propagation of this change to all places which use the :STANDARD +;;; readtable (and thus rendering this readtable to be non-standard, +;;; in fact.) + + +(defun constant-standard-readtable-expression-p (thing) + (cond ((symbolp thing) (or (eq thing 'nil) (eq thing :standard))) + ((consp thing) (some (lambda (x) (equal thing x)) + '((find-readtable nil) + (find-readtable :standard) + (ensure-readtable nil) + (ensure-readtable :standard)))) + (t nil))) + +(defun signal-suspicious-registration-warning (name-expr readtable-expr) + (simple-style-warn + "Caution: ~~% ~S" + (list name-expr name-expr) readtable-expr)) + +(let () + ;; Defer to runtime because compiler-macros are made available already + ;; at compilation time. So without this two subsequent invocations of + ;; COMPILE-FILE on this file would result in an undefined function + ;; error because the two above functions are not yet available. + ;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1; + ;; cf. last example in CLHS "EVAL-WHEN" entry.) + + (define-compiler-macro register-readtable (&whole form name readtable) + (when (constant-standard-readtable-expression-p readtable) + (signal-suspicious-registration-warning name readtable)) + form) + + (define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p)) + (when (and default-p (constant-standard-readtable-expression-p default)) + (signal-suspicious-registration-warning name default)) + form)) + + Added: trunk/lib/named-readtables/package.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/package.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,193 @@ + +(in-package :common-lisp-user) + +(defpackage :editor-hints.named-readtables + (:use :common-lisp) + (:nicknames :named-readtables) + (:export + #:defreadtable + #:in-readtable + #:make-readtable + #:merge-readtables-into + #:find-readtable + #:ensure-readtable + #:rename-readtable + #:readtable-name + #:register-readtable + #:unregister-readtable + #:copy-named-readtable + #:list-all-named-readtables + ;; Types + #:named-readtable-designator + ;; Conditions + #:reader-macro-conflict + #:readtable-does-already-exist + #:readtable-does-not-exist + ) + (:documentation + " +* What are Named-Readtables? + + Named-Readtables is a library that provides a namespace for + readtables akin to the already-existing namespace of packages. In + particular: + + * you can associate readtables with names, and retrieve + readtables by names; + + * you can associate source files with readtable names, and be + sure that the right readtable is active when compiling/loading + the file; + + * similiarly, your development environment now has a chance to + automatically determine what readtable should be active while + processing source forms on interactive commands. (E.g. think of + `C-c C-c' in Slime [yet to be done]) + + It follows that Named-Readtables is a facility for using readtables in + a localized way. + + Additionally, it also attempts to become a facility for using + readtables in a _modular_ way. In particular: + + * it provides a macro to specify the content of a readtable at a + glance; + + * it makes it possible to use multiple inheritance between readtables. + +* Notes on the API + + The API heavily imitates the API of packages. This has the nice + property that any experienced Common Lisper will take it up without + effort. + + DEFREADTABLE - DEFPACKAGE + + IN-READTABLE - IN-PACKAGE + + MERGE-READTABLES-INTO - USE-PACKAGE + + MAKE-READTABLE - MAKE-PACKAGE + + UNREGISTER-READTABLE - DELETE-PACKAGE + + RENAME-READTABLE - RENAME-PACKAGE + + FIND-READTABLE - FIND-PACKAGE + + READTABLE-NAME - PACKAGE-NAME + + LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES + +* Important API idiosyncrasies + + There are three major differences between the API of Named-Readtables, + and the API of packages. + + 1. Readtable names are symbols not strings. + + Time has shown that the fact that packages are named by + strings causes severe headache because of the potential of + package names colliding with each other. + + Hence, readtables are named by symbols lest to make the + situation worse than it already is. Consequently, readtables + named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can + happily coexist next to each other. Or, taken to an extreme, + SCHEME:SYNTAX and ELISP:SYNTAX. + + If, for example to duly signify the importance of your cool + readtable hack, you really think it deserves a global name, + you can always resort to keywords. + + 2. The inheritance is resolved statically, not dynamically. + + A package that uses another package will have access to all + the other package's exported symbols, even to those that will + be added after its definition. I.e. the inheritance is + resolved at run-time, that is dynamically. + + Unfortunately, we cannot do the same for readtables in a + portable manner. + + Therefore, we do not talk about \"using\" another readtable + but about \"merging\" the other readtable's definition into + the readtable we are going to define. I.e. the inheritance is + resolved once at definition time, that is statically. + + (Such merging can more or less be implemented portably albeit + at a certain cost. Most of the time, this cost manifests + itself at the time a readtable is defined, i.e. once at + compile-time, so it may not bother you. Nonetheless, we + provide extra support for Sbcl, ClozureCL, and AllegroCL at + the moment. Patches for your implementation of choice are + welcome, of course.) + + 3. DEFREADTABLE does not have compile-time effects. + + If you define a package via DEFPACKAGE, you can make that + package the currently active package for the subsequent + compilation of the same file via IN-PACKAGE. The same is, + however, not true for DEFREADTABLE and IN-READTABLE for the + following reason: + + It's unlikely that the need for special reader-macros arises + for a problem which can be solved in just one file. Most + often, you're going to define the reader macro functions, and + set up the corresponding readtable in an extra file. + + If DEFREADTABLE had compile-time effects, you'd have to wrap + each definition of a reader-macro function in an EVAL-WHEN to + make its definition available at compile-time. Because that's + simply not the common case, DEFREADTABLE does not have a + compile-time effect. + + If you want to use a readtable within the same file as its + definition, wrap the DEFREADTABLE and the reader-macro + function definitions in an explicit EVAL-WHEN. + +* Preregistered Readtables + + - NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/. + + - :MODERN designates a _case-preserving_ /standard-readtable/. + + - :CURRENT designates the /current readtable/. + +* Examples + + > (defreadtable elisp:syntax + > (:merge :standard) + > (:macro-char #\\? #'elisp::read-character-literal t) + > (:macro-char #\\[ #'elisp::read-vector-literal t) + > ... + > (:case :preserve)) + > + > (defreadtable scheme:syntax + > (:merge :standard) + > (:macro-char #\\[ #'(lambda (stream char) + > (read-delimited-list #\\] stream))) + > (:macro-char #\\# :dispatch) + > (:dispatch-macro-char #\\# #\\t #'scheme::read-#t) + > (:dispatch-macro-char #\\# #\\f #'scheme::read-#f) + > ... + > (:case :preserve)) + > + > (in-readtable elisp:syntax) + > + > ... + > + > (in-readtable scheme:syntax) + > + > ... + +* Acknowledgements + + Thanks to Robert Goldman for making me want to write this library. + + Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart + Botta, David Crawford, and Pascal Costanza for being early adopters, + providing comments and bugfixes. +")) + +(pushnew :named-readtables *features*) \ No newline at end of file Added: trunk/lib/named-readtables/tests/package.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/tests/package.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,12 @@ +;;; -*- Mode:Lisp -*- + +(in-package :cl-user) + +(defpackage :named-readtables-test + (:use :cl :named-readtables) + (:import-from :named-readtables + #:dispatch-macro-char-p + #:do-readtable + #:ensure-function + #:ensure-dispatch-macro-character + #:function=)) \ No newline at end of file Added: trunk/lib/named-readtables/tests/rt.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/tests/rt.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,256 @@ +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +;; (defpackage :rt +;; (:use #:cl) +;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing +;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests +;; #:rem-all-tests #:rem-test) +;; (:documentation "The MIT regression tester")) + +;; (in-package :rt) + +(in-package :named-readtables-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t + "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") +(defvar *compile-tests* nil + "When true, compile the tests before running them.") +(defvar *optimization-settings* '((safety 3))) +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters." + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (finish-output s) + (null pending)))) Added: trunk/lib/named-readtables/tests/tests.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/tests/tests.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,322 @@ +;;; -*- Mode:Lisp -*- + +(in-package :named-readtables-test) + +(defun map-alist (car-fn cdr-fn alist) + (mapcar #'(lambda (entry) + (cons (funcall car-fn (car entry)) + (funcall cdr-fn (cdr entry)))) + alist)) + +(defun length=1 (list) + (and list (null (cdr list)))) + +(defmacro signals-condition-p (name &body body) + `(handler-case (prog1 nil , at body) + (,(second name) () t))) + +(defmacro continue-condition (name &body body) + `(handler-bind ((,(second name) #'continue)) + , at body)) + +(defun read-with-readtable (name string) + (let ((*package* '#.*package*) + (*readtable* (find-readtable name))) + (values (read-from-string string)))) + +(defun random-named-readtable () + (let ((readtables (list-all-named-readtables))) + (nth (random (length readtables)) readtables))) + + +(defun readtable-content (named-readtable-designator) + (let ((readtable (ensure-readtable named-readtable-designator)) + (result '())) + ;; Make sure to canonicalize the order and function designators so + ;; we can compare easily. + (do-readtable ((char reader-fn ntp disp? table) readtable) + (setq table (sort (copy-list table) #'char< :key #'car)) + (push (list* char + (ensure-function reader-fn) + ntp + (and disp? (list (map-alist #'identity + #'ensure-function + table)))) + result)) + (sort result #'char< :key #'car))) + +(defun readtable= (rt1 rt2) + (tree-equal (readtable-content rt1) (readtable-content rt2) + :test #'(lambda (x y) + (if (and (functionp x) (functionp y)) + (function= x y) + (eql x y))))) + + +(defun read-A (stream c) + (declare (ignore stream c)) + :a) + +(defun read-A-as-X (stream c) + (declare (ignore stream c)) + :x) + +(defun read-B (stream c) + (declare (ignore stream c)) + :b) + +(defun read-sharp-paren (stream c n) + (declare (ignore stream c n)) + 'sharp-paren) + +(defun read-C (stream c) + (declare (ignore stream c)) + :c) + +(defreadtable A + (:macro-char #\A #'read-A)) + +(defreadtable A-as-X + (:macro-char #\A #'read-A-as-X)) + +(defreadtable B + (:macro-char #\B #'read-B)) + +(defreadtable C + (:macro-char #\C #'read-C)) + +(defreadtable A+B+C + (:merge A B C)) + +(defreadtable standard+A+B+C + (:merge :standard A+B+C)) + +(defreadtable sharp-paren + (:macro-char #\# :dispatch) + (:dispatch-macro-char #\# #\( #'read-sharp-paren)) + + +(deftest cruft.1 + (function= (get-macro-character #\" (copy-readtable nil)) + (get-macro-character #\" (copy-readtable nil))) + t) + +(deftest cruft.2 + (dispatch-macro-char-p #\# (find-readtable :standard)) + t) + +(deftest cruft.3 + (dispatch-macro-char-p #\# (make-readtable)) + nil) + +(deftest cruft.4 + (let ((rt (copy-named-readtable :standard))) + (ensure-dispatch-macro-character #\# t rt) + (dispatch-macro-char-p #\# rt)) + t) + +(deftest cruft.5 + (let ((rt (make-readtable))) + (values + (dispatch-macro-char-p #\$ rt) + (ensure-dispatch-macro-character #\$ t rt) + (dispatch-macro-char-p #\$ rt))) + nil t t) + +(deftest cruft.6 + (let ((rt (make-readtable)) + (fn (constantly nil))) + (ensure-dispatch-macro-character #\$ t rt) + (set-dispatch-macro-character #\$ #\# fn rt) + (values + (eq fn (get-dispatch-macro-character #\$ #\# rt)) + (length=1 (readtable-content rt)))) + t t) + +(deftest cruft.7 + (let ((rt (make-readtable)) + (fn (constantly nil))) + (set-macro-character #\$ fn t rt) + (values + (eq fn (get-macro-character #\$ rt)) + (length=1 (readtable-content rt)))) + t t) + + +(deftest standard.1 + (read-with-readtable :standard "ABC") + ABC) + +(deftest standard.2 + (read-with-readtable :standard "(A B C)") + (A B C)) + +(deftest standard.3 + (let ((x (find-readtable nil)) + (y (find-readtable :standard)) + (z (find-readtable :common-lisp))) + (and (eq x y) (eq y z))) + t) + + +(deftest modern.1 + (read-with-readtable :modern "FooF") + |FooF|) + + +(deftest empty.1 + (null (readtable-content (make-readtable))) + t) + +(deftest empty.2 + (readtable= (merge-readtables-into (make-readtable) :standard) + (find-readtable :standard)) + t) + +(deftest empty.3 + (let ((rt (copy-named-readtable :standard))) + (readtable= (merge-readtables-into (make-readtable) rt) + (merge-readtables-into rt (make-readtable)))) + t) + + +(deftest basics.1 + (read-with-readtable 'A "A") + :a) + +(deftest basics.2 + (read-with-readtable 'A-as-X "A") + :x) + +(deftest basics.3 + (read-with-readtable 'A "B") + B) + +(deftest basics.4 + (read-with-readtable 'A "(A B C)") + |(|) + + +(deftest unregister.1 + (let ((rt (find-readtable 'A))) + (register-readtable 'does-not-exist rt) + (values + (and (find-readtable 'does-not-exist) t) + (unregister-readtable 'does-not-exist) + (and (find-readtable 'does-not-exist) t))) + t t nil) + + +(deftest name.1 + (let ((rt (random-named-readtable))) + (eq rt (find-readtable (readtable-name rt)))) + t) + +(deftest ensure.1 + (unwind-protect + (let* ((x (ensure-readtable 'does-not-exist (find-readtable 'A))) + (y (find-readtable 'A)) + (z (find-readtable 'does-not-exist))) + (and (eq x y) (eq y z))) + (unregister-readtable 'does-not-exist)) + t) + + +(deftest merge.1 + (values + (read-with-readtable 'A+B+C "A") + (read-with-readtable 'A+B+C "B") + (read-with-readtable 'A+B+C "C")) + :a :b :c) + +(deftest merge.2 + (read-with-readtable 'standard+A+B+C "(A B C)") + (:a :b :c)) + +(deftest merge.3 + (read-with-readtable 'standard+A+B+C "#(A B C)") + #(:a :b :c)) + +(deftest merge.4 + (let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C) + :standard))) + (readtable= 'standard+A+B+C A+B+C+standard)) + t) + + +(deftest rename.1 + (unwind-protect + (progn (make-readtable 'A* :merge '(A)) + (rename-readtable 'A* 'A**) + (values (and (find-readtable 'A*) t) + (and (find-readtable 'A**) t))) + (unregister-readtable 'A*) + (unregister-readtable 'A**)) + nil + t) + + +(deftest reader-macro-conflict.1 + (signals-condition-p 'reader-macro-conflict + (merge-readtables-into (make-readtable) 'A 'A-as-X)) + t) + +(deftest reader-macro-conflict.2 + (signals-condition-p 'reader-macro-conflict + (merge-readtables-into (make-readtable) :standard :standard)) + nil) + +(deftest reader-macro-conflict.3 + (signals-condition-p 'reader-macro-conflict + (merge-readtables-into (make-readtable) 'A+B+C 'A)) + nil) + +(deftest reader-macro-conflict.4 + (signals-condition-p 'reader-macro-conflict + (merge-readtables-into (make-readtable) :standard 'sharp-paren)) + t) + + +(deftest readtable-does-not-exist.1 + (signals-condition-p 'readtable-does-not-exist + (ensure-readtable 'does-not-exist)) + t) + + +(deftest readtable-does-already-exist.1 + (signals-condition-p 'readtable-does-already-exist + (make-readtable 'A)) + t) + +(deftest readtable-does-already-exist.2 + (signals-condition-p 'readtable-does-already-exist + (make-readtable 'A)) + t) + +(deftest readtable-does-already-exist.3 + (let ((rt (make-readtable 'does-not-exist :merge '(:standard A B)))) + (declare (ignore rt)) + (unwind-protect + (read-with-readtable (continue-condition 'readtable-does-already-exist + (make-readtable 'does-not-exist + :merge '(:standard A C))) + + "(A B C)") + (unregister-readtable 'does-not-exist))) + (:a B :c)) + + +(deftest defreadtable.1 + (unwind-protect + (signals-condition-p 'reader-macro-conflict + (eval `(defreadtable does-not-exist (:merge A A-as-X)))) + (unregister-readtable 'does-not-exist)) + t) + +(deftest defreadtable.2 + (unwind-protect + (signals-condition-p 't + (eval `(defreadtable does-not-exist (:fuze A A-as-X)))) + (unregister-readtable 'does-not-exist)) + nil) + Added: trunk/lib/named-readtables/utils.lisp ============================================================================== --- (empty file) +++ trunk/lib/named-readtables/utils.lisp Thu Oct 22 16:10:10 2009 @@ -0,0 +1,245 @@ +;;;; +;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler +;;;; +;;;; All rights reserved. +;;;; +;;;; See LICENSE for details. +;;;; + +(in-package :editor-hints.named-readtables) + +(defmacro without-package-lock ((&rest package-names) &body body) + (declare (ignorable package-names)) + #+clisp + (return-from without-package-lock + `(ext:without-package-lock (, at package-names) , at body)) + #+lispworks + (return-from without-package-lock + `(let ((hcl:*packages-for-warn-on-redefinition* + (set-difference hcl:*packages-for-warn-on-redefinition* + '(, at package-names) + :key (lambda (package-designator) + (if (packagep package-designator) + (package-name package-designator) + package-designator)) + :test #'string=))) + , at body)) + `(progn , at body)) + +;;; Taken from SWANK (which is Public Domain.) + +(defmacro destructure-case (value &rest patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t , at body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + , at body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: ~S" ,tmp)))))))) + +;;; Taken from Alexandria (which is Public Domain, or BSD.) + +(define-condition simple-style-warning (simple-warning style-warning) + ()) + +(defun simple-style-warn (format-control &rest format-args) + (warn 'simple-style-warning + :format-control format-control + :format-arguments format-args)) + +(define-condition simple-program-error (simple-error program-error) + ()) + +(defun simple-program-error (message &rest args) + (error 'simple-program-error + :format-control message + :format-arguments args)) + +(defun required-argument (&optional name) + "Signals an error for a missing argument of NAME. Intended for +use as an initialization form for structure and class-slots, and +a default value for required keyword arguments." + (error "Required argument ~@[~S ~]missing." name)) + +(defun ensure-list (list) + "If LIST is a list, it is returned. Otherwise returns the list +designated by LIST." + (if (listp list) + list + (list list))) + +(declaim (inline ensure-function)) ; to propagate return type. +(declaim (ftype (function (t) (values function &optional)) + ensure-function)) +(defun ensure-function (function-designator) + "Returns the function designated by FUNCTION-DESIGNATOR: +if FUNCTION-DESIGNATOR is a function, it is returned, otherwise +it must be a function name and its FDEFINITION is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + +(defun parse-body (body &key documentation whole) + "Parses BODY into (values remaining-forms declarations doc-string). +Documentation strings are recognized only if DOCUMENTATION is true. +Syntax errors in body are signalled and WHOLE is used in the signal +arguments when given." + (let ((doc nil) + (decls nil) + (current nil)) + (tagbody + :declarations + (setf current (car body)) + (when (and documentation (stringp current) (cdr body)) + (if doc + (error "Too many documentation strings in ~S." (or whole body)) + (setf doc (pop body))) + (go :declarations)) + (when (and (listp current) (eql (first current) 'declare)) + (push (pop body) decls) + (go :declarations))) + (values body (nreverse decls) doc))) + +(defun parse-ordinary-lambda-list (lambda-list) + "Parses an ordinary lambda-list, returning as multiple values: + + 1. Required parameters. + 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP) + where SUPPLIEDP is NIL if not present. + 3. Name of the rest parameter, or NIL. + 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP) + where SUPPLIEDP is NIL if not present. + 5. Boolean indicating &ALLOW-OTHER-KEYS presence. + 6. &AUX parameter specifications, normalized into form (NAME INIT). + +Signals a PROGRAM-ERROR is the lambda-list is malformed." + (let ((state :required) + (allow-other-keys nil) + (auxp nil) + (required nil) + (optional nil) + (rest nil) + (keys nil) + (aux nil)) + (labels ((simple-program-error (format-string &rest format-args) + (error 'simple-program-error + :format-control format-string + :format-arguments format-args)) + (fail (elt) + (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (check-variable (elt what) + (unless (and (symbolp elt) (not (constantp elt))) + (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" + what elt lambda-list))) + (check-spec (spec what) + (destructuring-bind (init suppliedp) spec + (declare (ignore init)) + (check-variable suppliedp what))) + (make-keyword (name) + "Interns the string designated by NAME in the KEYWORD package." + (intern (string name) :keyword))) + (dolist (elt lambda-list) + (case elt + (&optional + (if (eq state :required) + (setf state elt) + (fail elt))) + (&rest + (if (member state '(:required &optional)) + (setf state elt) + (progn + (break "state=~S" state) + (fail elt)))) + (&key + (if (member state '(:required &optional :after-rest)) + (setf state elt) + (fail elt))) + (&allow-other-keys + (if (eq state '&key) + (setf allow-other-keys t + state elt) + (fail elt))) + (&aux + (cond ((eq state '&rest) + (fail elt)) + (auxp + (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (t + (setf auxp t + state elt)) + )) + (otherwise + (when (member elt '#.(set-difference lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux))) + (simple-program-error + "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (case state + (:required + (check-variable elt "required parameter") + (push elt required)) + (&optional + (cond ((consp elt) + (destructuring-bind (name &rest tail) elt + (check-variable name "optional parameter") + (if (cdr tail) + (check-spec tail "optional-supplied-p parameter") + (setf elt (append elt '(nil)))))) + (t + (check-variable elt "optional parameter") + (setf elt (cons elt '(nil nil))))) + (push elt optional)) + (&rest + (check-variable elt "rest parameter") + (setf rest elt + state :after-rest)) + (&key + (cond ((consp elt) + (destructuring-bind (var-or-kv &rest tail) elt + (cond ((consp var-or-kv) + (destructuring-bind (keyword var) var-or-kv + (unless (symbolp keyword) + (simple-program-error "Invalid keyword name ~S in ordinary ~ + lambda-list:~% ~S" + keyword lambda-list)) + (check-variable var "keyword parameter"))) + (t + (check-variable var-or-kv "keyword parameter") + (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))) + (if (cdr tail) + (check-spec tail "keyword-supplied-p parameter") + (setf tail (append tail '(nil)))) + (setf elt (cons var-or-kv tail)))) + (t + (check-variable elt "keyword parameter") + (setf elt (list (list (make-keyword elt) elt) nil nil)))) + (push elt keys)) + (&aux + (if (consp elt) + (destructuring-bind (var &optional init) elt + (declare (ignore init)) + (check-variable var "&aux parameter")) + (check-variable elt "&aux parameter")) + (push elt aux)) + (t + (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list))))))) + (values (nreverse required) (nreverse optional) rest (nreverse keys) + allow-other-keys (nreverse aux)))) \ No newline at end of file Modified: trunk/src/java/snow/Snow.java ============================================================================== --- trunk/src/java/snow/Snow.java (original) +++ trunk/src/java/snow/Snow.java Thu Oct 22 16:10:10 2009 @@ -152,11 +152,12 @@ } File f = new File(uri); baseDir = fixDirPath(f.getParentFile().getParent()); - libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator; + libDir = baseDir; } lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)"); lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)"); lispEngine.eval("(pushnew #P\"" + libDir + "cl-utilities-1.2.4/\" asdf:*central-registry* :test #'equal)"); + lispEngine.eval("(pushnew #P\"" + libDir + "named-readtables/\" asdf:*central-registry* :test #'equal)"); lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)"); lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)"); } @@ -168,7 +169,6 @@ 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; Modified: trunk/src/java/snow/example/example.lisp ============================================================================== --- trunk/src/java/snow/example/example.lisp (original) +++ trunk/src/java/snow/example/example.lisp Thu Oct 22 16:10:10 2009 @@ -1,4 +1,5 @@ (in-package :snow) +(in-readtable snow:syntax) (defmodel my-model () ((a :accessor aaa :initform (c-in "4")) @@ -33,7 +34,7 @@ (label :binding (make-bean-data-binding *object* "property1") :layout "wrap") (label :text "EL binding") - (label :binding (make-el-data-binding "bean.nested.property1") + (label :binding ${bean.nested.property1} :layout "wrap") (label :text "cells bindings: aaa and bbb") (label :binding (make-cells-data-binding (c? (aaa *cells-object*)))) @@ -47,7 +48,7 @@ (text-field :binding (make-bean-data-binding *object* "property1") :layout "growx, wrap") (label :text "set nested.property1") - (text-field :binding (make-el-data-binding "bean.nested.property1") + (text-field :binding ${bean.nested.property1} :layout "growx, wrap") (button :text "Test!" :layout "wrap" Modified: trunk/src/lisp/snow/compile-system.lisp ============================================================================== --- trunk/src/lisp/snow/compile-system.lisp (original) +++ trunk/src/lisp/snow/compile-system.lisp Thu Oct 22 16:10:10 2009 @@ -3,16 +3,13 @@ (unwind-protect (unless (progn - #|(pushnew #P"snow/" asdf:*central-registry* :test #'equal) - (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal) - (pushnew #P"cl-utilities-1.2.4/" asdf:*central-registry* :test #'equal) - (pushnew #P"cells/" asdf:*central-registry* :test #'equal) - (pushnew #P"cells/utils-kt/" asdf:*central-registry* :test #'equal) - (pushnew :snow-cells *features*)|# (jstatic "initAux" "snow.Snow") - (format t "asdf:*central-registry*: ~A" asdf:*central-registry*) - + (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")) + (format t "failed~%")) + (terpri) (quit)) \ No newline at end of file Modified: trunk/src/lisp/snow/data-binding.lisp ============================================================================== --- trunk/src/lisp/snow/data-binding.lisp (original) +++ trunk/src/lisp/snow/data-binding.lisp Thu Oct 22 16:10:10 2009 @@ -128,16 +128,31 @@ ;;For EL data bindings we reuse simple-data-binding, since its 'variable' can ;;really be any JGoodies ValueModel -(defun make-el-data-binding (el-expr) +(defun make-el-data-binding (obj path) + (make-instance 'simple-data-binding + :variable (new "snow.binding.BeanPropertyPathBinding" + obj (apply #'jvector "java.lang.String" path)))) + +(defun make-el-data-binding-from-expression (el-expr) + (print el-expr) (let* ((splitted-expr (split-sequence #\. el-expr)) (obj (funcall *bean-factory* (car splitted-expr))) (path (cdr splitted-expr))) - (make-instance 'simple-data-binding - :variable (new "snow.binding.BeanPropertyPathBinding" - obj (apply #'jvector "java.lang.String" path))))) + (make-el-data-binding obj path))) -;(defun make-bean-property-path-data-binding (object path) -;) +(defreadtable snow:syntax + (:merge :standard) + (:macro-char #\$ :dispatch) + (:dispatch-macro-char + #\$ #\{ + #'(lambda (stream char number) + (declare (ignore char number)) + `(make-el-data-binding-from-expression + ,(with-output-to-string (str) + (loop + :for ch := (read-char stream) :then (read-char stream) + :until (char= ch #\}) + :do (write-char ch str))))))) ;;Default binding types #|(defun default-data-binding-types () Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Thu Oct 22 16:10:10 2009 @@ -30,7 +30,7 @@ (defpackage :snow - (:use :common-lisp :java :cl-utilities #+snow-cells :cells) + (:use :common-lisp :java :cl-utilities :named-readtables #+snow-cells :cells) (:shadow #+snow-cells #:dbg) (:export ;;Widgets @@ -38,19 +38,24 @@ #:frame #:label #:panel + #:text-area #:text-field ;;Common operations on widgets #:hide #:pack #:show + ;;Data binding + #:make-var + #:var ;;Various #:install-graphical-debugger #:*parent* #:self + #:syntax #:with-widget ;;Java #:invoke #:new)) (defpackage :snow-user - (:use :common-lisp :snow :java :ext #+snow-cells :cells)) \ No newline at end of file + (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)) \ 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 Thu Oct 22 16:10:10 2009 @@ -32,7 +32,7 @@ (asdf:defsystem :snow :serial t :version "0.2" - :depends-on (:cl-utilities #+snow-cells :cells) + :depends-on (:cl-utilities :named-readtables #+snow-cells :cells) :components ((:file "packages") (:file "sexy-java") (:file "utils") From astalla at common-lisp.net Mon Oct 26 22:48:56 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 26 Oct 2009 18:48:56 -0400 Subject: [snow-cvs] r11 - in trunk: docs src/java/snow/binding src/lisp/snow Message-ID: Author: astalla Date: Mon Oct 26 18:48:55 2009 New Revision: 11 Log: Updated tutorial. Fixed a bug with EL binding and zero-length property paths. Modified: trunk/docs/tutorial.html trunk/src/java/snow/binding/BeanPropertyPathBinding.java trunk/src/lisp/snow/data-binding.lisp Modified: trunk/docs/tutorial.html ============================================================================== --- trunk/docs/tutorial.html (original) +++ trunk/docs/tutorial.html Mon Oct 26 18:48:55 2009 @@ -13,10 +13,11 @@
  • Layout
  • Event handling
  • Embedding Snow
    • +
  • Data Binding
  • What's more?

    • Getting and Installing Snow

    -You can download the latest Snow binary distribution from     http://alessiostalla.altervista.org/software/snow/index.php. It contains Snow and all its dependencies in a single Zip file. Since Snow can be used both in Lisp and Java applications, procedures for installing it can vary in each of the two cases. +You can download the latest Snow binary distribution from http://common-lisp.net/projects/snow/. It contains Snow and all its dependencies in a single Zip file. Since Snow can be used both in Lisp and Java applications, procedures for installing it can vary in each of the two cases.

    What's more?

    Modified: trunk/src/lisp/snow/data-binding.lisp ============================================================================== --- trunk/src/lisp/snow/data-binding.lisp (original) +++ trunk/src/lisp/snow/data-binding.lisp Tue Oct 27 17:36:21 2009 @@ -128,7 +128,7 @@ ;;For EL data bindings we reuse simple-data-binding, since its 'variable' can ;;really be any JGoodies ValueModel -(defun make-el-data-binding (obj path) +(defun make-property-data-binding (obj path) (make-instance 'simple-data-binding :variable (new "snow.binding.BeanPropertyPathBinding" obj (apply #'jvector "java.lang.String" path)))) @@ -138,7 +138,7 @@ (obj (funcall *bean-factory* (car splitted-expr))) (path (cdr splitted-expr))) (if path - (make-el-data-binding obj path) + (make-property-data-binding obj path) (make-simple-data-binding (make-var obj))))) (defreadtable snow:syntax