March 2005 - closure-cvs@common-lisp.net - mailman3.common-lisp.net

[closure-cvs] CVS update: cxml/xml/util.lisp cxml/xml/xml-name-rune-p.lisp cxml/xml/xml-parse.lisp
by dlichteblau＠common-lisp.net 25 Mar '05

25 Mar '05

Update of /project/cxml/cvsroot/cxml/xml In directory common-lisp.net:/tmp/cvs-serv9430/xml Modified Files: xml-name-rune-p.lisp xml-parse.lisp Added Files: util.lisp Log Message: - Moved utility functions from the "runes" package to the "cxml" package to avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.) Date: Fri Mar 25 19:17:36 2005 Author: dlichteblau Index: cxml/xml/xml-name-rune-p.lisp diff -u cxml/xml/xml-name-rune-p.lisp:1.1.1.10 cxml/xml/xml-name-rune-p.lisp:1.2 --- cxml/xml/xml-name-rune-p.lisp:1.1.1.10 Sun Mar 13 19:02:51 2005 +++ cxml/xml/xml-name-rune-p.lisp Fri Mar 25 19:17:34 2005 @@ -211,13 +211,13 @@ (setf (aref r i) 1))))) ) `(progn - (DEFSUBST NAME-RUNE-P (RUNE) + (DEFINLINE NAME-RUNE-P (RUNE) (SETF RUNE (RUNE-CODE RUNE)) (AND (<= 0 RUNE ,*max*) (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) (THE FIXNUM RUNE)))))) - (DEFSUBST NAME-START-RUNE-P (RUNE) + (DEFINLINE NAME-START-RUNE-P (RUNE) (SETF RUNE (RUNE-CODE RUNE)) (AND (<= 0 RUNE ,*MAX*) (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) Index: cxml/xml/xml-parse.lisp diff -u cxml/xml/xml-parse.lisp:1.1.1.121 cxml/xml/xml-parse.lisp:1.2 --- cxml/xml/xml-parse.lisp:1.1.1.121 Sun Mar 13 19:02:57 2005 +++ cxml/xml/xml-parse.lisp Fri Mar 25 19:17:35 2005 @@ -378,7 +378,7 @@ ) (defun make-rod-hashtable (&key (size 200)) - (setf size (runes::nearest-greater-prime size)) + (setf size (nearest-greater-prime size)) (make-rod-hashtable/low :size size :table (make-array size :initial-element nil))) @@ -392,13 +392,13 @@ (1- (expt 2 +fixnum-bits+)) "Pessimistic approximation of the largest bit-mask, still being a fixnum.")) -(defsubst stir (a b) +(definline stir (a b) (%and +fixnum-mask+ (%xor (%ior (%ash (%and a #.(ash +fixnum-mask+ -5)) 5) (%ash a #.(- 5 +fixnum-bits+))) b))) -(defsubst rod-hash (rod start end) +(definline rod-hash (rod start end) "Compute a hash code out of a rod." (let ((res (%- end start))) (do ((i start (%+ i 1))) @@ -407,7 +407,7 @@ (setf res (stir res (rune-code (%rune rod i))))) res)) -(defsubst rod=* (x y &key (start1 0) (end1 (length x)) +(definline rod=* (x y &key (start1 0) (end1 (length x)) (start2 0) (end2 (length y))) (and (%= (%- end1 start1) (%- end2 start2)) (do ((i start1 (%+ i 1)) @@ -417,7 +417,7 @@ (unless (rune= (%rune x i) (%rune y j)) (return nil))))) -(defsubst rod=** (x y start1 end1 start2 end2) +(definline rod=** (x y start1 end1 start2 end2) (and (%= (%- end1 start1) (%- end2 start2)) (do ((i start1 (%+ i 1)) (j start2 (%+ j 1))) @@ -1339,7 +1339,7 @@ (perror input "Expected \";\".")) (values :NAMED name)))))) -(defsubst read-S? (input) +(definline read-S? (input) (while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) :test #'eq) (consume-rune input))) @@ -1413,7 +1413,7 @@ (collect c)))) value)))) -(defsubst data-rune-p (rune) +(definline data-rune-p (rune) ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. (let ((c (rune-code rune))) (or (= c #x9) (= c #xA) (= c #xD)

1 0

[closure-cvs] CVS update: cxml/runes/characters.lisp cxml/runes/dep-acl.lisp cxml/runes/dep-acl5.lisp cxml/runes/dep-clisp.lisp cxml/runes/dep-cmucl-dtc.lisp cxml/runes/dep-cmucl.lisp cxml/runes/dep-openmcl.lisp cxml/runes/dep-sbcl.lisp cxml/runes/package.lisp cxml/runes/runes.lisp cxml/runes/xstream.lisp cxml/runes/util.lisp
by dlichteblau＠common-lisp.net 25 Mar '05

25 Mar '05

Update of /project/cxml/cvsroot/cxml/runes In directory common-lisp.net:/tmp/cvs-serv9430/runes Modified Files: characters.lisp dep-acl.lisp dep-acl5.lisp dep-clisp.lisp dep-cmucl-dtc.lisp dep-cmucl.lisp dep-openmcl.lisp dep-sbcl.lisp package.lisp runes.lisp xstream.lisp Removed Files: util.lisp Log Message: - Moved utility functions from the "runes" package to the "cxml" package to avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.) Date: Fri Mar 25 19:16:57 2005 Author: dlichteblau Index: cxml/runes/characters.lisp diff -u cxml/runes/characters.lisp:1.1.1.3 cxml/runes/characters.lisp:1.2 --- cxml/runes/characters.lisp:1.1.1.3 Sun Mar 13 19:02:56 2005 +++ cxml/runes/characters.lisp Fri Mar 25 19:16:56 2005 @@ -28,31 +28,31 @@ (deftype rod () '(vector character)) (deftype simple-rod () '(simple-array character)) -(defsubst rune (rod index) +(definline rune (rod index) (char rod index)) (defun (setf rune) (new rod index) (setf (char rod index) new)) -(defsubst %rune (rod index) +(definline %rune (rod index) (aref (the simple-string rod) (the fixnum index))) -(defsubst (setf %rune) (new rod index) +(definline (setf %rune) (new rod index) (setf (aref (the simple-string rod) (the fixnum index)) new)) (defun rod-capitalize (rod) (string-upcase rod)) -(defsubst code-rune (x) (code-char x)) -(defsubst rune-code (x) (char-code x)) +(definline code-rune (x) (code-char x)) +(definline rune-code (x) (char-code x)) -(defsubst rune= (x y) +(definline rune= (x y) (char= x y)) (defun rune-downcase (rune) (char-downcase rune)) -(defsubst rune-upcase (rune) +(definline rune-upcase (rune) (char-upcase rune)) (defun rune-upper-case-letter-p (rune) @@ -70,13 +70,13 @@ (defun rod-upcase (rod) (string-upcase rod)) -(defsubst white-space-rune-p (char) +(definline white-space-rune-p (char) (or (char= char #\tab) (char= char #.(code-char 10)) ;Linefeed (char= char #.(code-char 13)) ;Carriage Return (char= char #\space))) -(defsubst digit-rune-p (char &optional (radix 10)) +(definline digit-rune-p (char &optional (radix 10)) (digit-char-p char radix)) (defun rod (x) @@ -100,7 +100,7 @@ (defun rod-equal (x y) (string-equal x y)) -(defsubst make-rod (size) +(definline make-rod (size) (make-string size)) (defun char-rune (char) Index: cxml/runes/dep-acl.lisp diff -u cxml/runes/dep-acl.lisp:1.1.1.1 cxml/runes/dep-acl.lisp:1.2 --- cxml/runes/dep-acl.lisp:1.1.1.1 Sun Mar 13 19:02:27 2005 +++ cxml/runes/dep-acl.lisp Fri Mar 25 19:16:56 2005 @@ -28,13 +28,13 @@ ;; Unfortunately it is also incapable to declaim such functions inline. ;; So we revoke the DEFUN hack from dep-gcl here. -(defmacro runes::defsubst (fun args &body body) +(defmacro runes::definline (fun args &body body) (if (and (consp fun) (eq (car fun) 'setf)) (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (symbol-package (cadr fun))))) `(progn (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) - (runes::defsubst ,fnam ,args .,body))) + (runes::definline ,fnam ,args .,body))) `(progn (defun ,fun ,args .,body) (define-compiler-macro ,fun (&rest .args.) Index: cxml/runes/dep-acl5.lisp diff -u cxml/runes/dep-acl5.lisp:1.1.1.1 cxml/runes/dep-acl5.lisp:1.2 --- cxml/runes/dep-acl5.lisp:1.1.1.1 Sun Mar 13 19:02:27 2005 +++ cxml/runes/dep-acl5.lisp Fri Mar 25 19:16:56 2005 @@ -40,13 +40,13 @@ ;; Unfortunately it is also incapable to declaim such functions inline. ;; So we revoke the DEFUN hack from dep-gcl here. -(defmacro runes::defsubst (fun args &body body) +(defmacro runes::definline (fun args &body body) (if (and (consp fun) (eq (car fun) 'setf)) (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (symbol-package (cadr fun))))) `(progn (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) - (runes::defsubst ,fnam ,args .,body))) + (runes::definline ,fnam ,args .,body))) (labels ((declp (x) (and (consp x) (eq (car x) 'declare)))) `(progn Index: cxml/runes/dep-clisp.lisp diff -u cxml/runes/dep-clisp.lisp:1.1.1.2 cxml/runes/dep-clisp.lisp:1.2 --- cxml/runes/dep-clisp.lisp:1.1.1.2 Sun Mar 13 19:02:30 2005 +++ cxml/runes/dep-clisp.lisp Fri Mar 25 19:16:56 2005 @@ -53,7 +53,7 @@ ;;; `(progn ;;; ',name))) -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) Index: cxml/runes/dep-cmucl-dtc.lisp diff -u cxml/runes/dep-cmucl-dtc.lisp:1.1.1.1 cxml/runes/dep-cmucl-dtc.lisp:1.2 --- cxml/runes/dep-cmucl-dtc.lisp:1.1.1.1 Sun Mar 13 19:02:27 2005 +++ cxml/runes/dep-cmucl-dtc.lisp Fri Mar 25 19:16:56 2005 @@ -24,7 +24,7 @@ ;;; superseded by a newer version) or write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) Index: cxml/runes/dep-cmucl.lisp diff -u cxml/runes/dep-cmucl.lisp:1.1.1.1 cxml/runes/dep-cmucl.lisp:1.2 --- cxml/runes/dep-cmucl.lisp:1.1.1.1 Sun Mar 13 19:02:27 2005 +++ cxml/runes/dep-cmucl.lisp Fri Mar 25 19:16:56 2005 @@ -24,7 +24,7 @@ ;;; superseded by a newer version) or write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) Index: cxml/runes/dep-openmcl.lisp diff -u cxml/runes/dep-openmcl.lisp:1.1.1.1 cxml/runes/dep-openmcl.lisp:1.2 --- cxml/runes/dep-openmcl.lisp:1.1.1.1 Sun Mar 13 19:02:58 2005 +++ cxml/runes/dep-openmcl.lisp Fri Mar 25 19:16:56 2005 @@ -5,7 +5,7 @@ ;;;; ;;;; (c) copyright 1999 by Gilbert Baumann -(defmacro runes::defsubst (fun args &body body) +(defmacro runes::definline (fun args &body body) (if (consp fun) `(defun ,fun ,args ,@body) Index: cxml/runes/dep-sbcl.lisp diff -u cxml/runes/dep-sbcl.lisp:1.1.1.1 cxml/runes/dep-sbcl.lisp:1.2 --- cxml/runes/dep-sbcl.lisp:1.1.1.1 Sun Mar 13 19:02:27 2005 +++ cxml/runes/dep-sbcl.lisp Fri Mar 25 19:16:56 2005 @@ -24,7 +24,7 @@ ;;; superseded by a newer version) or write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) Index: cxml/runes/package.lisp diff -u cxml/runes/package.lisp:1.1.1.2 cxml/runes/package.lisp:1.2 --- cxml/runes/package.lisp:1.1.1.2 Sun Mar 13 19:02:27 2005 +++ cxml/runes/package.lisp Fri Mar 25 19:16:56 2005 @@ -10,15 +10,8 @@ (defpackage :runes (:use :cl) - (:export #:defsubst + (:export #:definline - ;; util.lisp : - #:compose - #:curry - #:rcurry - #:until - #:while - ;; runes.lisp #:rune #:rod Index: cxml/runes/runes.lisp diff -u cxml/runes/runes.lisp:1.1.1.4 cxml/runes/runes.lisp:1.2 --- cxml/runes/runes.lisp:1.1.1.4 Sun Mar 13 19:02:44 2005 +++ cxml/runes/runes.lisp Fri Mar 25 19:16:56 2005 @@ -42,26 +42,26 @@ (deftype rod () '(array rune (*))) (deftype simple-rod () '(simple-array rune (*))) -(defsubst rune (rod index) +(definline rune (rod index) (aref rod index)) (defun (setf rune) (new rod index) (setf (aref rod index) new)) -(defsubst %rune (rod index) +(definline %rune (rod index) (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index))) -(defsubst (setf %rune) (new rod index) +(definline (setf %rune) (new rod index) (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new)) (defun rod-capitalize (rod) (warn "~S is not implemented." 'rod-capitalize) rod) -(defsubst code-rune (x) x) -(defsubst rune-code (x) x) +(definline code-rune (x) x) +(definline rune-code (x) x) -(defsubst rune= (x y) +(definline rune= (x y) (= x y)) (defun rune-downcase (rune) @@ -70,7 +70,7 @@ ((<= #x00c0 rune #x00de) (+ rune #x20)) (t rune))) -(defsubst rune-upcase (rune) +(definline rune-upcase (rune) (cond ((<= #x0061 rune #x007a) (- rune #x20)) ((= rune #x00f7) rune) ((<= #x00e0 rune #x00fe) (- rune #x20)) @@ -95,13 +95,13 @@ ;; FIXME (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod)) -(defsubst white-space-rune-p (char) +(definline white-space-rune-p (char) (or (= char 9) ;TAB (= char 10) ;Linefeed (= char 13) ;Carriage Return (= char 32))) ;Space -(defsubst digit-rune-p (char &optional (radix 10)) +(definline digit-rune-p (char &optional (radix 10)) (cond ((<= #.(char-code #\0) char #.(char-code #\9)) (and (< (- char #.(char-code #\0)) radix) (- char #.(char-code #\0)))) @@ -141,7 +141,7 @@ (unless (rune-equal (rune x i) (rune y i)) (return nil))))) -(defsubst make-rod (size) +(definline make-rod (size) (make-array size :element-type 'rune)) (defun char-rune (char) Index: cxml/runes/xstream.lisp diff -u cxml/runes/xstream.lisp:1.1.1.5 cxml/runes/xstream.lisp:1.2 --- cxml/runes/xstream.lisp:1.1.1.5 Sun Mar 13 19:02:51 2005 +++ cxml/runes/xstream.lisp Fri Mar 25 19:16:56 2005 @@ -217,7 +217,7 @@ nil) ,input)) -(defsubst unread-rune (rune input) +(definline unread-rune (rune input) "Unread the last recently read rune; if there wasn't such a rune, you deserve to lose." (declare (ignore rune))

1 0

[closure-cvs] CVS update: cxml/dom/dom-impl.lisp
by dlichteblau＠common-lisp.net 25 Mar '05

25 Mar '05

Update of /project/cxml/cvsroot/cxml/dom In directory common-lisp.net:/tmp/cvs-serv9430/dom Modified Files: dom-impl.lisp Log Message: - Moved utility functions from the "runes" package to the "cxml" package to avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.) Date: Fri Mar 25 19:16:42 2005 Author: dlichteblau Index: cxml/dom/dom-impl.lisp diff -u cxml/dom/dom-impl.lisp:1.1.1.13 cxml/dom/dom-impl.lisp:1.2 --- cxml/dom/dom-impl.lisp:1.1.1.13 Sun Mar 13 19:02:51 2005 +++ cxml/dom/dom-impl.lisp Fri Mar 25 19:16:30 2005 @@ -698,7 +698,7 @@ (with-slots (children owner) node ;; remove children, add new TEXT-NODE child ;; (alas, we must not reuse an old TEXT-NODE) - (while (plusp (length children)) + (cxml::while (plusp (length children)) (dom:remove-child node (dom:last-child node))) (dom:append-child node (dom:create-text-node owner rod)))) new-value) @@ -819,7 +819,7 @@ (i 0) (previous nil)) ;; careful here, we're modifying the array we are iterating over - (while (< i (length children)) + (cxml::while (< i (length children)) (let ((child (elt children i))) (cond ((not (eq (dom:node-type child) :text))

1 0

[closure-cvs] CVS update: cxml/cxml.asd
by dlichteblau＠common-lisp.net 25 Mar '05

25 Mar '05

Update of /project/cxml/cvsroot/cxml In directory common-lisp.net:/tmp/cvs-serv9430 Modified Files: cxml.asd Log Message: - Moved utility functions from the "runes" package to the "cxml" package to avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.) Date: Fri Mar 25 19:16:29 2005 Author: dlichteblau Index: cxml/cxml.asd diff -u cxml/cxml.asd:1.1.1.32 cxml/cxml.asd:1.2 --- cxml/cxml.asd:1.1.1.32 Sun Mar 13 19:02:58 2005 +++ cxml/cxml.asd Fri Mar 25 19:16:29 2005 @@ -61,7 +61,6 @@ #+rune-is-character "characters" :depends-on ("package" dependent)) (:file "syntax" :depends-on ("package" dependent runes)) - (:file "util" :depends-on ("package" dependent)) (:file "encodings" :depends-on ("package")) (:file "encodings-data" :depends-on ("package" "encodings")) (:file "xstream" @@ -74,11 +73,12 @@ (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((:file "package") + (:file "util" :depends-on ("package")) (:file "sax-handler") (:file "characters" :depends-on ("package")) (:file "xml-name-rune-p" :depends-on ("package")) (:file "split-sequence" :depends-on ("package")) - (:file "xml-parse" :depends-on ("package" "sax-handler" "split-sequence" "xml-name-rune-p" "characters")) + (:file "xml-parse" :depends-on ("package" "util" "sax-handler" "split-sequence" "xml-name-rune-p" "characters")) (:file "characters" :depends-on ("package")) (:file "unparse" :depends-on ("xml-parse")) (:file "xmls-compat" :depends-on ("xml-parse"))

1 0

[closure-cvs] CVS update: closure/src/renderer/clim-draw.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv25449/src/renderer Modified Files: clim-draw.lisp Log Message: - Fix for CLX VALUE-ERRORs when drawing dashed lines with a dash distance of zero, in CLIM-DRAW-BORDER Date: Sun Mar 13 22:39:19 2005 Author: emarsden Index: closure/src/renderer/clim-draw.lisp diff -u closure/src/renderer/clim-draw.lisp:1.2 closure/src/renderer/clim-draw.lisp:1.3 --- closure/src/renderer/clim-draw.lisp:1.2 Sun Mar 13 19:03:24 2005 +++ closure/src/renderer/clim-draw.lisp Sun Mar 13 22:39:19 2005 @@ -4,7 +4,7 @@ ;;; Created: 2003-03-08 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-draw.lisp,v 1.2 2005/03/13 18:03:24 gbaumann Exp $ +;;; $Id: clim-draw.lisp,v 1.3 2005/03/13 21:39:19 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -66,6 +66,7 @@ (list x1 y1 x2 y2 x3 y3 x4 y4) :filled t :ink ink)) ((:dotted) + (let ((sw (max w 1))) (clim:draw-line* medium (/ (+ x1 x2) 2) (/ (+ y1 y2) 2) @@ -74,11 +75,10 @@ :ink ink :line-thickness w :line-cap-shape :round - :line-dashes (vector w (* 3 w)))) + :line-dashes (vector sw (* 3 sw))))) ((:dashed) - ;; this triggers an CLX value-error - #+NIL - (clim:draw-line* medium + (let ((sw (max 1 w))) + (clim:draw-line* medium (/ (+ x1 x2) 2) (/ (+ y1 y2) 2) (/ (+ x3 x4) 2) @@ -86,7 +86,7 @@ :ink ink :line-thickness w :line-cap-shape :square - :line-dashes (vector (* 3 w) (* 3 w)))) + :line-dashes (vector (* 3 sw) (* 3 sw))))) ((:double) (clim:draw-polygon* medium (list x1 y1

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv24362/src/gui Modified Files: clim-gui.lisp Log Message: - Implement PageUp and PageDown support in the CLIM GUI. - Add a Redraw command (with Ctrl-R accelerator) Date: Sun Mar 13 22:17:28 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.15 closure/src/gui/clim-gui.lisp:1.16 --- closure/src/gui/clim-gui.lisp:1.15 Sun Mar 13 22:15:06 2005 +++ closure/src/gui/clim-gui.lisp Sun Mar 13 22:17:28 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.15 2005/03/13 21:15:06 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.16 2005/03/13 21:17:28 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.16 2005/03/13 21:17:28 emarsden +;; - Implement PageUp and PageDown support in the CLIM GUI. +;; - Add a Redraw command (with Ctrl-R accelerator) +;; ;; Revision 1.15 2005/03/13 21:15:06 emarsden ;; Add zoom support to the renderer, accessible via the commands com-zoom-in, ;; com-zoom-out and com-zoom-100%. @@ -640,4 +644,26 @@ (write-status "Zooming out...") (setq closure::*zoom-factor* (* closure::*zoom-factor* 0.8)) (send-closure-command 'com-reflow)) + +(define-closure-command (com-page-up :name t + :keystroke :prior) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)) + (current-y (gadget-value scrollbar)) + (window-height (bounding-rectangle-height (pane-viewport-region pane)))) + (scroll-extent pane 0 (max (gadget-min-value scrollbar) (- current-y (* 0.9 window-height)))))) + +(define-closure-command (com-page-down :name t + :keystroke :next) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)) + (current-y (gadget-value scrollbar)) + (window-height (bounding-rectangle-height (pane-viewport-region pane)))) + (scroll-extent pane 0 + (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height)))))) + +(define-closure-command (com-redraw :name t :keystroke (#\r :control)) () + (let* ((*medium* (find-pane-named *frame* 'canvas)) ) + (handle-repaint *medium* (sheet-region (pane-viewport *medium*)))) + (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))

1 0

[closure-cvs] CVS update: closure/src/renderer/clim-device.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv23543/src/renderer Modified Files: clim-device.lisp Log Message: Add zoom support to the renderer, accessible via the commands com-zoom-in, com-zoom-out and com-zoom-100%. Date: Sun Mar 13 22:15:09 2005 Author: emarsden Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.8 closure/src/renderer/clim-device.lisp:1.9 --- closure/src/renderer/clim-device.lisp:1.8 Sun Mar 13 20:24:16 2005 +++ closure/src/renderer/clim-device.lisp Sun Mar 13 22:15:09 2005 @@ -31,8 +31,7 @@ (defclass clim-device () ((medium :accessor clim-device-medium :initarg :medium) (font-database :initform nil) - (zoom-factor :initform 1.2 :initarg :zoom-factor) - )) + (zoom-factor :initform closure::*zoom-factor* :initarg :zoom-factor))) (defmethod device-dpi ((device clim-device)) (with-slots (zoom-factor) device

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv23543/src/gui Modified Files: clim-gui.lisp Log Message: Add zoom support to the renderer, accessible via the commands com-zoom-in, com-zoom-out and com-zoom-100%. Date: Sun Mar 13 22:15:07 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.14 closure/src/gui/clim-gui.lisp:1.15 --- closure/src/gui/clim-gui.lisp:1.14 Sun Mar 13 21:58:31 2005 +++ closure/src/gui/clim-gui.lisp Sun Mar 13 22:15:06 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.14 2005/03/13 20:58:31 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.15 2005/03/13 21:15:06 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.15 2005/03/13 21:15:06 emarsden +;; Add zoom support to the renderer, accessible via the commands com-zoom-in, +;; com-zoom-out and com-zoom-100%. +;; ;; Revision 1.14 2005/03/13 20:58:31 emarsden ;; - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t ;; so that commands are available from listener pane @@ -83,6 +87,7 @@ (defvar closure:*home-page* "http://www.stud.uni-karlsruhe.de/~unk6/closure/user.html") (defvar closure:*user-wants-images-p* t) +(defvar closure::*zoom-factor* 1.0) (defvar *closure-process* nil) @@ -619,4 +624,20 @@ (clim:window-clear (clim:frame-query-io clim:*application-frame*))) ;;;; ---------------------------------------------------------------------------------------------------- + + +(define-closure-command (com-zoom-100% :name t) () + (setq closure::*zoom-factor* 1.0) + (send-closure-command 'com-reflow)) + +;; FIXME the :shift here is a McCLIM bug +(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control :shift)) () + (write-status "Zooming in...") + (setq closure::*zoom-factor* (* closure::*zoom-factor* 1.2)) + (send-closure-command 'com-reflow)) + +(define-closure-command (com-zoom-out :name t :keystroke (#\- :control :shift)) () + (write-status "Zooming out...") + (setq closure::*zoom-factor* (* closure::*zoom-factor* 0.8)) + (send-closure-command 'com-reflow))

1 0

[closure-cvs] CVS update: closure/src/html/html-style.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/html In directory common-lisp.net:/tmp/cvs-serv23140/src/html Modified Files: html-style.lisp Log Message: - Fix use of *STYLE-SHEET-CACHE*/LOCK. Was causing recursive lock attempts that were detected by SBCL's mutexes. Date: Sun Mar 13 22:01:59 2005 Author: emarsden Index: closure/src/html/html-style.lisp diff -u closure/src/html/html-style.lisp:1.3 closure/src/html/html-style.lisp:1.4 --- closure/src/html/html-style.lisp:1.3 Sun Mar 13 19:01:54 2005 +++ closure/src/html/html-style.lisp Sun Mar 13 22:01:59 2005 @@ -389,22 +389,24 @@ (defun maybe-parse-style-sheet-from-url (url &key (name "anonymous") (supersheet nil) (media-type :all)) - (mp/with-lock (*style-sheet-cache*/lock) - (multiple-value-bind (looked presentp) (gethash url *style-sheet-cache*) - (cond (presentp - (format T "~&;; Serving style sheet ~S [at ~S] from cache.~%" - name url) - looked) - (t - (format T "~&;; fetching and parsing style sheet ~S [at ~S].~%" - name url) - (let ((res (maybe-parse-style-sheet-from-url-aux - url - :name name - :supersheet supersheet - :media-type media-type))) - (setf (gethash url *style-sheet-cache*) res) - res)))))) + (multiple-value-bind (looked presentp) + (mp/with-lock (*style-sheet-cache*/lock) + (gethash url *style-sheet-cache*)) + (cond (presentp + (format *debug-io* "~&;; Serving style sheet ~S [at ~S] from cache.~%" + name url) + looked) + (t + (format *debug-io* "~&;; fetching and parsing style sheet ~S [at ~S].~%" + name url) + (let ((res (maybe-parse-style-sheet-from-url-aux + url + :name name + :supersheet supersheet + :media-type media-type))) + (mp/with-lock (*style-sheet-cache*/lock) + (setf (gethash url *style-sheet-cache*) res)) + res))))) (defun maybe-parse-style-sheet-from-url-aux (url &key (name "anonymous") (supersheet nil)

1 0

[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
by emarsden＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv22604/src/gui Modified Files: clim-gui.lisp Log Message: - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t so that commands are available from listener pane Date: Sun Mar 13 21:58:31 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.13 closure/src/gui/clim-gui.lisp:1.14 --- closure/src/gui/clim-gui.lisp:1.13 Sun Mar 13 20:24:14 2005 +++ closure/src/gui/clim-gui.lisp Sun Mar 13 21:58:31 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.13 2005/03/13 19:24:14 gbaumann Exp $ +;;; $Id: clim-gui.lisp,v 1.14 2005/03/13 20:58:31 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.14 2005/03/13 20:58:31 emarsden +;; - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t +;; so that commands are available from listener pane +;; ;; Revision 1.13 2005/03/13 19:24:14 gbaumann ;; make it at least compile and show a window with CMUCL 19a and cvs mcclim. ;; @@ -85,7 +89,7 @@ (defclass closure-pane (application-pane) ()) -;;; Curde History +;;; Crude History (defvar *back-history* nil) (defvar *forw-history* nil) @@ -259,10 +263,10 @@ ;;;; Commands ;;;; -(define-closure-command com-show-listener () +(define-closure-command (com-show-listener :name t) () (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) t)) -(define-closure-command com-hide-listener () +(define-closure-command (com-hide-listener :name t) () (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) nil)) (define-closure-command (com-visit-url :name t) ((url 'url)) ;;; :gesture :select)) @@ -277,10 +281,10 @@ (let ((*standard-output* *trace-output*)) (foo url))) -(define-closure-command com-reflow () +(define-closure-command (com-reflow :name t) () (reflow)) -(define-closure-command com-back () +(define-closure-command (com-back :name t) () (let ((*standard-output* *query-io*)) (cond ((null (cdr *back-history*)) (format t "There is nowhere you can go back to.~%")) @@ -289,7 +293,7 @@ (format t "Going back to ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command com-forward () +(define-closure-command (com-forward :name t) () (let ((*standard-output* *query-io*)) (cond ((null *forw-history*) (format t "There is nowhere you can go forward to.~%")) @@ -298,7 +302,7 @@ (format t "Going forward to ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command com-reload () +(define-closure-command (com-reload :name t) () (let ((*standard-output* *query-io*)) (cond ((null *back-history*) (format t "There is nothing to reload.~%")) @@ -306,15 +310,15 @@ (format t "Reloading ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command com-images-off () +(define-closure-command (com-images-off :name t) () (setf closure:*user-wants-images-p* nil) (format *query-io* "Images are now off.~%")) -(define-closure-command com-images-on () +(define-closure-command (com-images-on :name t) () (setf closure:*user-wants-images-p* t) (format *query-io* "Images are now on. You may want to reload.~%")) -(define-closure-command com-quit () +(define-closure-command (com-quit :name t) () (throw 'closure-quit nil)) (defun make-google-search-url (string) @@ -325,15 +329,15 @@ (cons "q" string))) (url:parse-url "http://www.google.com/search"))) -(define-closure-command com-reverse-search-google ((url 'url)) +(define-closure-command (com-reverse-search-google :name t) ((url 'url)) (let ((*standard-output* *trace-output*)) (com-visit-url (make-google-search-url (format nil "link:~A" url))))) -(define-closure-command com-search-google ((what 'string)) +(define-closure-command (com-search-google :name t) ((what 'string)) (com-visit-url (make-google-search-url what))) -(define-closure-command com-home () +(define-closure-command (com-home :name t) () (com-visit-url closure:*home-page*)) (define-presentation-translator fofo

1 0