August 2005 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Apps/Listener/icons/wild.xpm
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener/icons In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener/icons Added Files: wild.xpm Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert(a)morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:41 2005 Author: mretzlaff

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/file-types.lisp mcclim/Apps/Listener/util.lisp
by mretzlaff＠common-lisp.net 31 Aug '05

31 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv17279/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp util.lisp Log Message: This patch affects the CLIM-Listener. It adds : - sort-by for filenames to COM-SHOW-DIRECTORY, - an icon and a cond-clause in ICON-OF for wild pathnames, - a wrapper for LIST-DIRECTORY (that NCONCs the direct subdirectories of the directory to the output of LIST-DIRECTORY if it is called with a wild pathname), - and does some minor changes to COM-SHOW-DIRECTORY. Also it removes the SB-POSIX LIST-DIRECTORY for SBCL as that one completely ignores the pathname-name and -type, which renders it quite useless for :wild searches (pune or play on words intended). There was a short discussion about this patch in #lisp some hourse ago. As a result the wrapper for LIST-DIRECTORY is now called LIST-DIRECTORY-WITH-ALL-DIRECT-SUBDIRECTORIES. And it will only used by COM-SHOW-DIRECTORY if its new keyword parameter :list-all-direct-subdirectories is specified as t (the default being nil). The discussion (included because of the removed posix code in the former SBCL version of LIST-DIRECTORY): 01:18 < mgr> hefner: Did you have a look at my listener patch? 01:19 < hefner> I did, it looked good 01:19 < mgr> hefner: You are not angry because it removes the posix stuff? :) 01:20 < hefner> mgr: did it? :) The posix stuff was horrible, terrible. 01:20 < mgr> hefner: So, you don't object if I commit it to the mcclim repository? 01:20 < hefner> mgr: no, go ahead 01:22 < mgr> hefner: Perhaps there should be a option to COM-SHOW-DIRECTORY to switch between using LIST-DIRECTORY and LIST-DIRECTORY-WITH-ALL-SUBDIRECTORIES? Perhaps the latter is not always desired.. 01:22 < hefner> mgr: :recursive t ? 01:23 < mgr> hefner: No, it's different. if you list "/tmp/*.list" all direct subdirectories of "/tmp/" will be listed as well, altough they do not match "*.lisp". 01:24 < hefner> ah.. 01:27 < hefner> mgr: hold on, you're just calling cl:directory? Isn't that going to explode on broken symlinks? 01:33 < mgr> hefner: Uhm, explode? not really, no. Why? Symlinks are just "resolved" on sbcl. That is if you select "/foo/bar" that is a symlink to "/baz/quux", you'll always get the latter even if you select the former one. 01:34 < gilberth> mgr: not so fast. I have major hassle with CMUCL and XEmacs silly lock symlinks. 01:34 < hefner> mgr: what if /baz/quux doesn't exist? I didn't write the aweful posix code for my health. 01:35 < gilberth> They point to silly stuff like "gilbert(a)morganit.local.6092" 01:36 < mgr> gilberth: Well, the listener did always do only #'directory for cmucl.. So, don't worry this does not affect you. :) 01:36 < gilberth> great. 01:37 < hefner> not only #'directory, but (directory pathname :truenamep nil) 01:39 < gilberth> mgr: It must use the right keyword options to #'directory in CMUCL or something, since it works with borken symlinks. 01:39 < gilberth> it even shows a particular icon for the broken symlink. 01:39 < hefner> does it? that's a nice touch. 01:40 < gilberth> hefner: I thought you would know? 01:40 < hefner> I guess I forgot. 01:45 < mgr> hefner: there ist no problem with them. they will not be resolved, that is #p"/foo/bar" will be returned. it will be displayed as an invalid pathname because probe-file returns nil. 01:46 < hefner> mgr: I guess the behaviour changed. SBCL of 1.5 years ago didn't do that. Carry on. :) 01:47 < mgr> hefner: Also the posix version completely ignores the pathname-name and -type, and that's really not nice. 01:47 < hefner> well, pathname-name and pathname-type aren't nice either 01:47 < hefner> pathnames aren't nice 01:47 < mgr> hefner: Well, that's a different problem. 01:48 < mgr> hefner: I'll include this short discussion into the commit message, okay? :) 01:48 < hefner> okay Date: Wed Aug 31 07:50:38 2005 Author: mretzlaff Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.29 mcclim/Apps/Listener/dev-commands.lisp:1.30 --- mcclim/Apps/Listener/dev-commands.lisp:1.29 Thu Apr 21 05:41:24 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Wed Aug 31 07:50:37 2005 @@ -1028,7 +1028,9 @@ (terpri stream)) (defun sort-pathnames (list sort-by) - list) ; <--- FIXME + (case sort-by ; <--- FIXME + ('name (sort list #'string-lessp :key #'file-namestring)) + (t list))) (defun split-sort-pathnames (list group-dirs sort-by) (mapcar (lambda (x) (sort-pathnames x sort-by)) @@ -1064,31 +1066,37 @@ :provide-output-destination-keyword t) ((pathname 'pathname #+nil(or 'string 'pathname) :prompt "pathname") &key - #+NIL (sort-by '(member name size modify none) :default 'name) + (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default T :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member items list) :default 'items :prompt "listing style") (group-directories 'boolean :default T :prompt "group directories?") - (full-names 'boolean :default nil :prompt "show full name?")) + (full-names 'boolean :default nil :prompt "show full name?") + (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) (let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this.. (merge-pathnames pathname) pathname)) - (dir (list-directory (gen-wild-pathname pathname)))) + (wild-pathname (gen-wild-pathname pathname)) + (dir (if list-all-direct-subdirectories + (list-directory-with-all-direct-subdirectories wild-pathname) + (list-directory wild-pathname)))) (with-text-family (T :sans-serif) (invoke-as-heading (lambda () (format T "Directory contents of ") - (present pathname))) + (present (directory-namestring pathname) 'pathname) + (when (pathname-type pathname) + (format T " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (T (parent-directory pathname) 'clim:pathname) + (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname) (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) (format T "Parent Directory~%"))) - (dolist (group (split-sort-pathnames dir group-directories :none #+NIL sort-by)) + (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style @@ -1105,7 +1113,8 @@ (goatee::reposition-stream-cursor *standard-output*) (vertical-gap T)) (list (dolist (ent group) - (let ((ent (merge-pathnames ent pathname))) ; This is for CMUCL, see above. (fixme!) + (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) + ;; And breaks some things for SBCL.. (mgr) (pretty-pretty-pathname ent *standard-output* :long-name full-names))))))))) #+nil ; OBSOLETE Index: mcclim/Apps/Listener/file-types.lisp diff -u mcclim/Apps/Listener/file-types.lisp:1.7 mcclim/Apps/Listener/file-types.lisp:1.8 --- mcclim/Apps/Listener/file-types.lisp:1.7 Sun Nov 9 22:12:05 2003 +++ mcclim/Apps/Listener/file-types.lisp Wed Aug 31 07:50:37 2005 @@ -133,7 +133,8 @@ ;; ICON-OF is measurably slow here in CMUCL. Interesting.. (defmethod icon-of ((pathname pathname)) - (cond ((not (probe-file pathname)) (standard-icon "invalid.xpm")) + (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) + ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types (T (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.17 mcclim/Apps/Listener/util.lisp:1.18 --- mcclim/Apps/Listener/util.lisp:1.17 Tue Feb 22 04:10:27 2005 +++ mcclim/Apps/Listener/util.lisp Wed Aug 31 07:50:37 2005 @@ -118,6 +118,8 @@ #+SBCL (defun list-directory (pathname) + (directory pathname) + #+nil ;; ugh. is too ughy. (mgr) (let* ((pathname (strip-filespec pathname)) ;; ugh. (dir (sb-posix:opendir pathname)) (list nil)) @@ -141,6 +143,19 @@ (defun list-directory (pathname) (directory pathname)) +;;; Calls LIST-DIRECTORY and appends the subdirectories of the directory +;;; PATHNAME to the output of LIST-DIRECTORY if PATHNAME is a wild pathname. + +(defun list-directory-with-all-direct-subdirectories (pathname) + (let ((file-list (list-directory pathname))) + (if (wild-pathname-p pathname) + (nconc file-list + (delete-if (lambda (directory) + (member directory file-list :test #'equal)) + (delete-if-not #'directoryp + (list-directory (gen-wild-pathname + (strip-filespec pathname)))))) + file-list))) ;;; A farce of a "portable" run-program, which grows as I need options from ;;; the CMUCL run-program.

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by mretzlaff＠common-lisp.net 29 Aug '05

29 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15426 Modified Files: panes.lisp Log Message: Added a method PANE-BORDER that works just like PANE-VIEWPORT and PANE-SCROLLER, only for BORDER-PANEs. It is not in the spec, but so is the BORDER-PANE as a whole. (And, yes, I needed it.) In addition to this it changes the IFs in PANE-VIEWPORT and PANE-SCROLLER to WHENs (both had no else-forms). (Minor change: Five changes in the comments: The section titles of the different panes are made consistent. (Most of them were of the pattern "FOO PANE", only five of them "FOO-PANE"; as I liked the former pattern more, they are now all of that pattern.)) Date: Tue Aug 30 00:39:31 2005 Author: mretzlaff Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.154 mcclim/panes.lisp:1.155 --- mcclim/panes.lisp:1.154 Fri Aug 19 04:20:35 2005 +++ mcclim/panes.lisp Tue Aug 30 00:39:31 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.155 2005/08/29 22:39:31 mretzlaff Exp $ (in-package :clim-internals) @@ -795,7 +795,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; BASIC-PANE +;;; BASIC PANE (defclass basic-pane (;; layout-protocol-mixin standard-space-requirement-options-mixin @@ -957,7 +957,7 @@ (event window-manager-delete-event)) (frame-exit (pane-frame (event-sheet event)))) -;;;; UNMANAGED-TOP-LEVEL-SHEET-PANE +;;;; UNMANAGED-TOP-LEVEL-SHEET PANE (defclass unmanaged-top-level-sheet-pane (top-level-sheet-pane) () @@ -1643,7 +1643,7 @@ (- width border-width border-width) (- height border-width border-width))))) -;;; OUTLINED-PANE +;;; OUTLINED PANE ;; same as SPACING-PANE but a different default background. @@ -1654,7 +1654,7 @@ (defmacro outlining ((&rest options) &body contents) `(make-pane 'outlined-pane ,@options :contents (list ,@contents))) -;;; BORDER-PANE +;;; BORDER PANE ;; same as outlined-pane, but thickness is now called border-width. @@ -1667,6 +1667,11 @@ (defmacro bordering ((&rest options) &body contents) `(make-pane 'border-pane ,@options :contents (list ,@contents))) +(defmethod pane-border ((pane basic-pane)) + (let ((parent (sheet-parent pane))) + (when (and parent (typep parent 'border-pane)) + parent))) + ;;; RAISED PANE (defclass raised-pane (border-pane permanent-medium-sheet-output-mixin) @@ -1751,7 +1756,7 @@ (note-input-focus-changed (sheet-child pane) state)) ;;;; -;;;; SCROLLER-PANE +;;;; SCROLLER PANE ;;;; ;;; How scrolling is done @@ -2033,9 +2038,8 @@ (defmethod pane-viewport ((pane basic-pane)) (let ((parent (sheet-parent pane))) - (if (and parent (typep parent 'viewport-pane)) - parent - nil))) + (when (and parent (typep parent 'viewport-pane)) + parent))) ;;; Default for streams that aren't even panes. @@ -2051,7 +2055,7 @@ (defmethod pane-scroller ((pane basic-pane)) (let ((viewport (pane-viewport pane))) - (if viewport + (when viewport (sheet-parent viewport)))) (defmethod scroll-extent ((pane basic-pane) x y)

1 0

[mcclim-cvs] CVS update: mcclim/Tests/regions.lisp
by rstrandh＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30153/Tests Added Files: regions.lisp Log Message: Hopefully the beginning of a testing framework for McCLIM. Date: Fri Aug 26 21:58:38 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Tests
by rstrandh＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Tests In directory common-lisp.net:/tmp/cvs-serv30107/Tests Log Message: Directory /project/mcclim/cvsroot/mcclim/Tests added to the repository Date: Fri Aug 26 21:56:59 2005 Author: rstrandh New directory mcclim/Tests added

1 0

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by mretzlaff＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12901 Modified Files: dialog.lisp Log Message: (climi::frame-event-queue *application-frame*) as argument :INPUT-BUFFER to the call of OPEN-WINDOW-STREAM in WITH-STREAM-IN-OWN-WINDOW (was not specified previously). The ugly delay could be dropped, because no new process is created anymore. See http://common-lisp.net/pipermail/mcclim-devel/2005-August/004239.html for more information. (Thanks go to Christophe.) The parameter :LABEL to ACCEPTING-VALUES will now actually be used to label the newly created window if :OWN-WINDOW is true. Date: Fri Aug 26 02:32:56 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.21 mcclim/dialog.lisp:1.22 --- mcclim/dialog.lisp:1.21 Thu Aug 25 22:48:40 2005 +++ mcclim/dialog.lisp Fri Aug 26 02:32:56 2005 @@ -138,12 +138,13 @@ (defmacro with-stream-in-own-window ((&optional (stream '*query-io*) &rest further-streams) + (&optional label) &rest body) - `(let* ((,stream (open-window-stream)) + `(let* ((,stream (open-window-stream :label ,label + :input-buffer (climi::frame-event-queue *application-frame*))) ,@(mapcar (lambda (a-stream) (list a-stream stream)) further-streams)) - (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened (unwind-protect (progn ,@body) @@ -159,7 +160,7 @@ &body body) (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame - align-prompts label scroll-bars + align-prompts scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) @@ -171,7 +172,9 @@ ,@args)) )) `(if ,own-window - (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + (with-stream-in-own-window (,stream *standard-input* *standard-output*) + (,label) + ,return-form) ,return-form)))) (defun invoke-accepting-values

2 2

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by mretzlaff＠common-lisp.net 25 Aug '05

25 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26547 Modified Files: dialog.lisp Log Message: A patch against the first bug a patch by me introduced to mcclim. Sorry, that shouldn't have happened.. At least it was only a bug in a feature that the patch introduced (displaying an ACCEPTING-VALUES dialog in its :OWN-WINDOW), and it affected only code that thoughtlessly relied of this new and still broken feature. (Broken because OPEN-WINDOW-STREAM doesn't really work yet. I think there has to be a (redisplay-frame-panes frame) or something like that in its event-loop (that is the function STANDALONE-EVENT-LOOP).) Date: Thu Aug 25 22:48:41 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.20 mcclim/dialog.lisp:1.21 --- mcclim/dialog.lisp:1.20 Fri Aug 19 02:48:25 2005 +++ mcclim/dialog.lisp Thu Aug 25 22:48:40 2005 @@ -170,9 +170,9 @@ #',accepting-values-continuation ,@args)) )) - (if own-window - `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) - return-form)))) + `(if ,own-window + (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + ,return-form)))) (defun invoke-accepting-values (stream body

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by mretzlaff＠common-lisp.net 25 Aug '05

25 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23472 Modified Files: presentation-defs.lisp Log Message: This patch HANDLER-BINDs the ABORT-GESTURE condition to #'abort for the function ACCEPT in presentation-defs.lisp. ABORT-GESTURE is the condition that is signaled when any of the gestures in *ABORT-GESTURES* is read (in STREAM-READ-GESTURE). Right now *ABORT-GESTURES* contains only :abort on mcclim, which is a the keyboard gesture (#\c :control) (on Genera it contains #\Abort, the ABORT-key). I do not find explicitly in the clim specification that an ACCEPT should be aborted on an ABORT-GESTURE, but it seems to be the right thing (and I have to admit that I haven't been looking very hard). I did short tests with ACCEPTING-VALUES and it seems to behave correctly with this patch, i.e. the whole dialog will be aborted. But perhaps it would be nicer if, as long as a gadget of the dialog is selected, only the edit of that gadget were aborted. Date: Thu Aug 25 22:24:12 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.45 mcclim/presentation-defs.lisp:1.46 --- mcclim/presentation-defs.lisp:1.45 Mon Aug 8 19:15:07 2005 +++ mcclim/presentation-defs.lisp Thu Aug 25 22:24:10 2005 @@ -664,71 +664,72 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (let* ((real-type (expand-presentation-type-abbreviation type)) - (real-default-type (cond (default-type-p - (expand-presentation-type-abbreviation - default-type)) - ((or defaultp provide-default) - real-type) - (t nil))) - (real-history-type (cond ((null historyp) real-type) - ((null history) nil) - (t (expand-presentation-type-abbreviation - history)))) - (*recursive-accept-p* *recursive-accept-1-p*) - (*recursive-accept-1-p* t)) - (with-keywords-removed (rest-args (:stream)) - (when (or default-type-p defaultp) - (setf rest-args - (list* :default-type real-default-type rest-args))) - (when historyp - (setf rest-args (list* :history real-history-type rest-args))) - (cond ((and viewp (symbolp view)) - (setf rest-args - (list* :view (funcall #'make-instance view) rest-args))) - ((consp view) - (setf rest-args - (list* :view (apply #'make-instance view) rest-args)))) - ;; Presentation type history interaction. According to the spec, - ;; if provide-default is true, we take the default from the - ;; presentation history. In addition, we'll implement the Genera - ;; behavior of temporarily putting the default on the history - ;; stack so the user can conveniently suck it in. - (flet ((do-accept (args) - (apply #'stream-accept stream real-type args)) - (get-history () - (when real-history-type - (funcall-presentation-generic-function - presentation-type-history-for-stream - real-history-type stream)))) - (let* ((default-from-history (and (not defaultp) provide-default)) - (history (get-history)) - (results - (multiple-value-list - (if history - (let ((*active-history-type* real-history-type)) - (cond (defaultp - (with-object-on-history - (history default real-default-type) - (do-accept rest-args))) - (default-from-history - (multiple-value-bind - (history-default history-type) - (presentation-history-head history - real-default-type) - (do-accept (if history-type - (list* :default history-default - :default-type history-type - rest-args) - rest-args)))) - (t (do-accept rest-args)))) - (do-accept rest-args)))) - (results-history (get-history))) - (when results-history - (presentation-history-add results-history - (car results) - (cadr results))) - (values-list results)))))) + (handler-bind ((abort-gesture #'abort)) + (let* ((real-type (expand-presentation-type-abbreviation type)) + (real-default-type (cond (default-type-p + (expand-presentation-type-abbreviation + default-type)) + ((or defaultp provide-default) + real-type) + (t nil))) + (real-history-type (cond ((null historyp) real-type) + ((null history) nil) + (t (expand-presentation-type-abbreviation + history)))) + (*recursive-accept-p* *recursive-accept-1-p*) + (*recursive-accept-1-p* t)) + (with-keywords-removed (rest-args (:stream)) + (when (or default-type-p defaultp) + (setf rest-args + (list* :default-type real-default-type rest-args))) + (when historyp + (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) + ;; Presentation type history interaction. According to the spec, + ;; if provide-default is true, we take the default from the + ;; presentation history. In addition, we'll implement the Genera + ;; behavior of temporarily putting the default on the history + ;; stack so the user can conveniently suck it in. + (flet ((do-accept (args) + (apply #'stream-accept stream real-type args)) + (get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream)))) + (let* ((default-from-history (and (not defaultp) provide-default)) + (history (get-history)) + (results + (multiple-value-list + (if history + (let ((*active-history-type* real-history-type)) + (cond (defaultp + (with-object-on-history + (history default real-default-type) + (do-accept rest-args))) + (default-from-history + (multiple-value-bind + (history-default history-type) + (presentation-history-head history + real-default-type) + (do-accept (if history-type + (list* :default history-default + :default-type history-type + rest-args) + rest-args)))) + (t (do-accept rest-args)))) + (do-accept rest-args)))) + (results-history (get-history))) + (when results-history + (presentation-history-add results-history + (car results) + (cadr results))) + (values-list results))))))) (defgeneric stream-accept (stream type &key

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-ffi.lisp
by crhodes＠common-lisp.net 22 Aug '05

22 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv12313 Modified Files: freetype-ffi.lisp Log Message: Make the Freetype FFI 32/64 agnostic. Untested on CMUCL, but I don't think the previous version worked on CMUCL either. Date: Mon Aug 22 11:28:35 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-ffi.lisp diff -u mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 mcclim/Experimental/freetype/freetype-ffi.lisp:1.3 --- mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 Sun Jun 5 22:50:29 2005 +++ mcclim/Experimental/freetype/freetype-ffi.lisp Mon Aug 22 11:28:34 2005 @@ -1,6 +1,9 @@ ;;; automatically generated, hand tweaked, do not regenerate. -(DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien #+cmucl :alien) +(DEFPACKAGE :FREETYPE + (:USE :cl + #+sbcl :sb-alien + #+cmucl :alien #+cmucl :c-call) (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" @@ -37,8 +40,6 @@ "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) -;;(declaim (sb-ext:muffle-conditions sb-int:deprecation-warning)) - (in-package :freetype) #+cmucl @@ -75,6 +76,52 @@ (define-alien-type freetype:ufast (unsigned 32)) +(define-alien-type freetype:ptrdiff-t (signed 32)) + +(define-alien-type freetype:size-t (unsigned 32)) + +(define-alien-type freetype:wchar-t (signed 32)) + +(define-alien-type freetype:wint-t (unsigned 32)) + +(define-alien-type freetype:bool (unsigned 8)) + +(define-alien-type freetype:fword (signed 16)) + +(define-alien-type freetype:ufword (unsigned 16)) + +(define-alien-type freetype:char (signed 8)) + +(define-alien-type freetype:byte (unsigned 8)) + +(define-alien-type freetype:string (signed 8)) + +(define-alien-type freetype:short (signed 16)) + +(define-alien-type freetype:ushort (unsigned 16)) + +(define-alien-type freetype:int (signed 32)) + +(define-alien-type freetype:uint (unsigned 32)) + +(define-alien-type freetype:long long) + +(define-alien-type freetype:ulong unsigned-long) + +(define-alien-type freetype:f2dot14 (signed 16)) + +(define-alien-type freetype:f26dot6 long) + +(define-alien-type freetype:fixed long) + +(define-alien-type freetype:error (signed 32)) + +(define-alien-type freetype:pointer (* t)) + +(define-alien-type freetype:offset freetype:size-t) + +(define-alien-type freetype:ptr-dist freetype:size-t) + (define-alien-type nil (enum nil (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) @@ -118,7 +165,10 @@ (struct freetype::memory-rec- (freetype:user (* t)) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func))) -(define-alien-type freetype:stream-desc (union freetype::stream-desc- (freetype:value (signed 32)) (freetype:pointer (* t)))) +(define-alien-type freetype:stream-desc + (union freetype::stream-desc- + (freetype:value long) + (freetype:pointer (* t)))) (define-alien-type freetype:stream-io (* t)) @@ -127,8 +177,8 @@ (define-alien-type nil (struct freetype::stream-rec- (freetype:base (* (unsigned 8))) - (freetype:size (unsigned 32)) - (freetype:pos (unsigned 32)) + (freetype:size freetype:ulong) + (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) @@ -137,7 +187,7 @@ (freetype:cursor (* (unsigned 8))) (freetype:limit (* (unsigned 8))))) -(define-alien-type freetype:pos (signed 32)) +(define-alien-type freetype:pos long) (define-alien-type freetype:vector (struct freetype::vector- (freetype:x freetype:pos) (freetype:y freetype:pos))) @@ -229,52 +279,6 @@ (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func))) -(define-alien-type freetype:ptrdiff-t (signed 32)) - -(define-alien-type freetype:size-t (unsigned 32)) - -(define-alien-type freetype:wchar-t (signed 32)) - -(define-alien-type freetype:wint-t (unsigned 32)) - -(define-alien-type freetype:bool (unsigned 8)) - -(define-alien-type freetype:fword (signed 16)) - -(define-alien-type freetype:ufword (unsigned 16)) - -(define-alien-type freetype:char (signed 8)) - -(define-alien-type freetype:byte (unsigned 8)) - -(define-alien-type freetype:string (signed 8)) - -(define-alien-type freetype:short (signed 16)) - -(define-alien-type freetype:ushort (unsigned 16)) - -(define-alien-type freetype:int (signed 32)) - -(define-alien-type freetype:uint (unsigned 32)) - -(define-alien-type freetype:long (signed 32)) - -(define-alien-type freetype:ulong (unsigned 32)) - -(define-alien-type freetype:f2dot14 (signed 16)) - -(define-alien-type freetype:f26dot6 (signed 32)) - -(define-alien-type freetype:fixed (signed 32)) - -(define-alien-type freetype:error (signed 32)) - -(define-alien-type freetype:pointer (* t)) - -(define-alien-type freetype:offset freetype:size-t) - -(define-alien-type freetype:ptr-dist freetype:size-t) - (define-alien-type freetype:unit-vector (struct freetype::unit-vector- (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14))) @@ -310,7 +314,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:size-metrics @@ -347,7 +351,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec))

1 0

[mcclim-cvs] CVS update: mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 22 Aug '05

22 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv18523 Modified Files: manual.tex Log Message: Fixed the figure of the example application according to a mail from Dan Barlow in July of 2003. Date: Mon Aug 22 04:49:06 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.30 mcclim/Doc/manual.tex:1.31 --- mcclim/Doc/manual.tex:1.30 Sun Aug 14 08:20:12 2005 +++ mcclim/Doc/manual.tex Mon Aug 22 04:49:05 2005 @@ -394,7 +394,8 @@ \begin{figure} \begin{center} -\includegraphics{ex2} +\epsfxsize=5in +\epsffile{ex2.eps} \end{center} \caption{\label{figex2} View of the improved example} \end{figure}

1 0