January 2006 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim
by tmoore 28 Jan '06

28 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv15840 Modified Files: frames.lisp Log Message: Put (declare (ignorable frame-class)) in the right function --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/01/28 00:38:04 1.111 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/01/28 00:47:18 1.112 @@ -946,7 +946,6 @@ (with-keywords-removed (options (:pretty-name :frame-manager :enable :state :left :top :right :bottom :width :height :save-under :frame-class)) - (declare (ignorable frame-class)) (let ((frame (apply #'make-instance frame-class :name frame-name :pretty-name pretty-name @@ -973,6 +972,7 @@ (own-process *multiprocessing-p*) port frame-manager frame-class &allow-other-keys) + (declare (ignorable frame-class)) (let ((frame (unless (eq create :force) (block found-frame

1 0

[mcclim-cvs] CVS mcclim
by tmoore 28 Jan '06

28 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv15419 Modified Files: frames.lisp package.lisp Log Message: Implemented destroy-frame and map-over-frames. Implemented find-application-frame from the Franz User Manual. CLIM Launcher folks might want to take a look at it. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2005/11/28 13:51:05 1.110 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/01/28 00:38:04 1.111 @@ -198,7 +198,7 @@ (user-supplied-geometry :initform nil :initarg :user-supplied-geometry :documentation "plist of defaulted :left, :top, :bottom, :right, :width and :height options.") - (process :reader frame-process :initform (current-process)) + (process :accessor frame-process :initform nil) (client-settings :accessor client-settings :initform nil))) (defmethod frame-geometry ((frame application-frame)) @@ -465,10 +465,12 @@ (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys) - (handler-case - (funcall (frame-top-level-lambda frame) frame) - (frame-exit () - nil))) + (letf (((frame-process frame) (current-process))) + (handler-case + (funcall (frame-top-level-lambda frame) frame) + (frame-exit () + nil)))) + (defmethod run-frame-top-level :around ((frame application-frame) &key) (let ((*application-frame* frame) @@ -686,6 +688,7 @@ (defgeneric enable-frame (frame)) (defgeneric disable-frame (frame)) +(defgeneric destroy-frame (frame)) (defgeneric note-frame-enabled (frame-manager frame)) (defgeneric note-frame-disbled (frame-manager frame)) @@ -700,6 +703,11 @@ (setf (slot-value frame 'state) :disabled) (note-frame-disabled (frame-manager frame) frame)) +(defmethod destroy-frame ((frame application-frame)) + (when (eq (frame-state frame) :enabled) + (disable-frame frame)) + (disown-frame (frame-manager frame) frame)) + (defmethod note-frame-enabled ((fm frame-manager) frame) (declare (ignore frame)) t) @@ -708,6 +716,15 @@ (declare (ignore frame)) t) +(defun map-over-frames (function &key port frame-manager) + (cond (frame-manager + (mapc function (frame-manager-frames frame-manager))) + (port + (loop for manager in (frame-managers port) + do (map-over-frames function :frame-manager manager))) + (t (loop for p in *all-ports* + do (map-over-frames function :port p))))) + (defvar *pane-realizer* nil) (defmacro with-look-and-feel-realization ((frame-manager frame) &body body) @@ -929,6 +946,7 @@ (with-keywords-removed (options (:pretty-name :frame-manager :enable :state :left :top :right :bottom :width :height :save-under :frame-class)) + (declare (ignorable frame-class)) (let ((frame (apply #'make-instance frame-class :name frame-name :pretty-name pretty-name @@ -948,6 +966,39 @@ (warn ":state ~S not supported yet." state))) frame))) +;;; From Franz Users Guide + +(defun find-application-frame (frame-name &rest initargs + &key (create t) (activate t) + (own-process *multiprocessing-p*) port + frame-manager frame-class + &allow-other-keys) + (let ((frame (unless (eq create :force) + (block + found-frame + (map-over-frames + #'(lambda (frame) + (when (eq (frame-name frame) frame-name) + (return-from found-frame frame))) + :port port + :frame-manager frame-manager))))) + (unless (or frame create) + (return-from find-application-frame nil)) + (unless frame + (with-keywords-removed (initargs (:create :activate :own-process)) + (setq frame (apply #'make-application-frame frame-name initargs)))) + (when (and frame activate) + (cond ((frame-process frame) + #-(and)(raise-frame frame)) ; not yet + (own-process + (clim-sys:make-process #'(lambda () + (run-frame-top-level frame)) + :name (format nil "~A" frame-name))) + (t (run-frame-top-level frame)))) + frame)) + + + ;;; Menu frame class (defclass menu-frame () --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/01/11 08:30:55 1.51 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/01/28 00:38:04 1.52 @@ -691,6 +691,7 @@ #:extended-output-stream-p ;predicate #:filling-output ;macro #:find-applicable-translators ;function + #:find-application-frame ;function (in Franz User's Guide) #:find-cached-output-record ;generic function #:find-child-output-record ;generic function #:find-command-from-command-line-name ;function

1 0

[mcclim-cvs] CVS mcclim/docs/guided-tour
by cfruhwirth 26 Jan '06

26 Jan '06

Update of /project/mcclim/cvsroot/mcclim/docs/guided-tour In directory common-lisp:/tmp/cvs-serv24673/docs/guided-tour Added Files: Makefile color-editor.lisp draw-frame.lisp file-browser-all file-browser.lisp guided-tour.bib guided-tour.tex hello-world.lisp scheduler.lisp simple-draw.lisp simple-spreadsheet.lisp techno-dep.fig Log Message: Initial checkin of my "A Guided Tour to CLIM" rework 2006. I put the tree under docs/ because I felt that this was more standard. I would like to suggest that we move Doc/ to docs/manual. --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/Makefile 2006/01/26 07:09:34 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/Makefile 2006/01/26 07:09:34 1.1 #!/usr/bin/make guided-tour.dvi: guided-tour.tex hello-world.cut draw-frame.cut scheduler.cut file-browser.cut techno-dep.pstex_t techno-dep.pstex latex guided-tour.tex bibtex guided-tour latex guided-tour.tex latex guided-tour.tex %.pstex: %.fig fig2dev -L pstex $(value $@) -b 0 $< $@ %.pstex_t: %.pstex %.fig fig2dev -L pstex_t $(value $@) -E 1 -p $^ $@ %.cut: %.lisp awk '/LTAG-end/ { found=found " " active; active="" } \ { if (active!="") print $$active > active} \ /LTAG-start/ { split($$2,foo,":"); active=foo[2] } \ END { print found }' $< .PHONY: clean clean: rm guided-tour.aux guided-tour.bbl guided-tour.log guided-tour.dvi guided-tour.blg hello-world-def-app hello-world-defclass hello-world-handle-repaint scheduler-part1 scheduler-part2 techno-dep.pstex techno-dep.pstex_t file-browser-all draw-frame-interfacing draw-frame-def-app draw-frame-commands --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/color-editor.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/color-editor.lisp 2006/01/26 07:09:35 1.1 (eval-when (:compile-toplevel :load-toplevel :execute) (asdf:oos 'asdf:load-op :clim) (asdf:oos 'asdf:load-op :clim-clx)) (in-package :clim-user) (defun make-color-slider (id initval label) (labelling (:label label) (make-pane ':slider :id id :orientation :horizontal :value initval :max-value 1 :min-value 0 :drag-callback #'color-slider-dragged :value-changed-callback #'color-slider-value-changed))) (define-application-frame color-editor () (current-color-pane drag-feedback-pane (red :initform 0.0) (green :initform 1.0) (blue :initform 0.0)) (:pane (with-slots (drag-feedback-pane current-color-pane red green blue) *application-frame* (vertically () (setf current-color-pane (make-pane 'application-pane :min-height 100 :max-height 100 :background (make-rgb-color red green blue))) (horizontally (:min-height 200 :max-height 200) (1/2 (make-color-slider 'red red "Red")) (1/4 (make-color-slider 'green green "Green")) (1/4 (make-color-slider 'blue blue "Blue"))) +fill+ (setf drag-feedback-pane (make-pane 'application-pane :min-height 100 :max-height 100 :background (make-rgb-color red green blue)))))) (:menu-bar t)) (defun color-slider-dragged (slider value) (with-slots (drag-feedback-pane red green blue) *application-frame* (setf (medium-background drag-feedback-pane) (ecase (gadget-id slider) (red (make-rgb-color value green blue)) (green (make-rgb-color red value blue)) (blue (make-rgb-color red green value)))) (redisplay-frame-pane *application-frame* drag-feedback-pane))) (defun color-slider-value-changed (slider new-value) (with-slots (current-color-pane red green blue) *application-frame* ;; The gadget-id symbols match the slot names in color-editor (setf (slot-value *application-frame* (gadget-id slider)) new-value) (setf (medium-background current-color-pane) (make-rgb-color red green blue)) (redisplay-frame-pane *application-frame* current-color-pane))) (define-color-editor-command (com-quit :name "Quit" :menu t) () (frame-exit *application-frame*)) --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/draw-frame.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/draw-frame.lisp 2006/01/26 07:09:35 1.1 (eval-when (:compile-toplevel) (asdf:oos 'asdf:load-op :clim) (asdf:oos 'asdf:load-op :clim-clx)) (in-package :clim-user) ; LTAG-start:draw-frame-def-app (define-application-frame draw-frame () ((lines :accessor lines :initform nil) ;; lines of drawing (strings :accessor strings :initform nil)) ;; texts of drawing (:panes (draw-pane (make-pane 'draw-pane)) (interactor :interactor)) (:layouts (default-default (vertically () draw-pane interactor)) (:menu-bar t) (:command-definer t) (:top-level (default-frame-top-level))) (defclass draw-pane (standard-extended-input-stream ; must have precedence over basic-pane basic-pane permanent-medium-sheet-output-mixin) ()) (defmethod handle-repaint ((pane draw-pane) region) (with-application-frame (frame) (call-next-method) ; Paints the background (dolist (line (lines frame)) (draw-line pane (car line) (cdr line))) (dolist (pair (strings frame)) (draw-text pane (cdr pair) (car pair))))) ; LTAG-end (defmethod frame-standard-output ((frame draw-frame)) (get-frame-pane frame 'interactor)) ; LTAG-start:draw-frame-commands (define-draw-frame-command (com-draw-add-string :menu t :name t) ((string 'string) (x 'integer) (y 'integer)) (push (cons (make-point x y) string) (strings *application-frame*)) (update-draw-pane)) (define-draw-frame-command (com-draw-add-line :menu t :name t) ((x1 'integer) (y1 'integer) (x2 'integer) (y2 'integer)) (with-slots (lines) *application-frame* (push (cons (make-point x1 y1) (make-point x2 y2)) lines)) (update-draw-pane)) (define-draw-frame-command (com-draw-clear :menu t :name t) () (with-slots (lines strings) *application-frame* (setf lines nil strings nil)) (update-draw-pane)) ;; Auxilary Method (defun update-draw-pane () (repaint-sheet (find-pane-named *application-frame* 'draw-pane) +everywhere+)) ; LTAG-end ; LTAG-start:draw-frame-interfacing (defmethod handle-event ((pane draw-pane) (event pointer-button-press-event)) ;; Start line tracking when left pointer button is pressed (when (eql (pointer-event-button event) +pointer-left-button+) (track-line-drawing pane (pointer-event-x event) (pointer-event-y event)))) (defmethod handle-event ((pane draw-pane) (event key-press-event)) (when (keyboard-event-character event) (multiple-value-bind (x y) (stream-pointer-position pane) ;; Start with empty string, as a key release event will be received anyway (track-text-drawing pane "" x y))) (update-draw-pane)) (defun track-line-drawing (pane startx starty) (let ((lastx startx) (lasty starty)) (with-drawing-options (pane :ink +flipping-ink+) (draw-line* pane startx starty lastx lasty) (tracking-pointer (pane) (:pointer-motion (&key window x y) (draw-line* pane startx starty lastx lasty) ; delete old (draw-line* pane startx starty x y) ; draw new (setq lastx x lasty y)) (:pointer-button-release (&key event x y) (when (eql (pointer-event-button event) +pointer-left-button+) (draw-line* pane startx starty lastx lasty) (execute-frame-command *application-frame* `(com-draw-add-line ,startx ,starty ,x ,y)) (return-from track-line-drawing nil))))))) (defun track-text-drawing (pane current-string current-x current-y) (tracking-pointer (pane) (:pointer-motion (&key window x y) ;; We can't use flipping ink for text, hence redraw. (handle-repaint pane +everywhere+) (setq current-x x current-y y) (draw-text* pane current-string x y)) (:keyboard (&key gesture) (when (and (typep gesture 'key-release-event) (keyboard-event-character gesture)) (setf current-string (concatenate 'string current-string (string (keyboard-event-character gesture)))) (handle-repaint pane +everywhere+) (draw-text* pane current-string current-x current-y))) (:pointer-button-release (&key event x y) (when (eql (pointer-event-button event) +pointer-left-button+) (execute-frame-command *application-frame* `(com-draw-add-string ,current-string ,x ,y)) (return-from track-text-drawing nil))))) ; LTAG-end:draw-frame-part2 --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/file-browser-all 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/file-browser-all 2006/01/26 07:09:35 1.1 (define-application-frame file-browser () ((active-files :initform nil :accessor active-files)) (:panes (file-browser :application :display-function '(dirlist-display-files) ;; Call the display-function whenever the command ;; loop makes a ``full-cycle'' :display-time :command-loop) (interactor :interactor)) (:layouts (default (vertically () file-browser interactor)))) (defmethod dirlist-display-files ((frame file-browser) pane) ;; Clear old displayed entries (clear-output-record (stream-output-history pane)) (dolist (file (active-files frame)) ;; Instead of write-string, we use present so that the link to ;; object file and the semantic information that file is ;; pathname is retained. (present file 'pathname :stream pane) (terpri pane))) (define-file-browser-command (com-edit-directory :name "Edit Directory") ((dir 'pathname)) (let ((dir (make-pathname :directory (pathname-directory dir) :name :wild :type :wild :version :wild :defaults dir))) (setf (active-files *application-frame*) (directory dir)))) (define-presentation-to-command-translator pathname-to-edit-command (pathname ; source presentation-type com-edit-directory ; target-command file-browser ; command-table :gesture :select ; use this translator for pointer clicks :documentation "Edit this path") ; used in context menu (object) ; argument List (list object)) ; arguments for target-command (defmethod adopt-frame :after (frame-manager (frame file-browser)) (execute-frame-command frame `(com-edit-directory ,(make-pathname :directory '(:absolute))))) --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/file-browser.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/file-browser.lisp 2006/01/26 07:09:35 1.1 (eval-when (:compile-toplevel) (asdf:oos 'asdf:load-op :clim) (asdf:oos 'asdf:load-op :clim-clx)) (in-package :clim-user) ; LTAG-start:file-browser-all (define-application-frame file-browser () ((active-files :initform nil :accessor active-files)) (:panes (file-browser :application :display-function '(dirlist-display-files) ;; Call the display-function whenever the command ;; loop makes a ``full-cycle'' :display-time :command-loop) (interactor :interactor)) (:layouts (default (vertically () file-browser interactor)))) (defmethod dirlist-display-files ((frame file-browser) pane) ;; Clear old displayed entries (clear-output-record (stream-output-history pane)) (dolist (file (active-files frame)) ;; Instead of write-string, we use present so that the link to ;; object file and the semantic information that file is ;; pathname is retained. (present file 'pathname :stream pane) (terpri pane))) (define-file-browser-command (com-edit-directory :name "Edit Directory") ((dir 'pathname)) (let ((dir (make-pathname :directory (pathname-directory dir) :name :wild :type :wild :version :wild :defaults dir))) (setf (active-files *application-frame*) (directory dir)))) (define-presentation-to-command-translator pathname-to-edit-command (pathname ; source presentation-type com-edit-directory ; target-command file-browser ; command-table :gesture :select ; use this translator for pointer clicks :documentation "Edit this path") ; used in context menu (object) ; argument List (list object)) ; arguments for target-command (defmethod adopt-frame :after (frame-manager (frame file-browser)) (execute-frame-command frame `(com-edit-directory ,(make-pathname :directory '(:absolute))))) ; LTAG-end--- /project/mcclim/cvsroot/mcclim/docs/guided-tour/guided-tour.bib 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/guided-tour.bib 2006/01/26 07:09:35 1.1 @misc { inside-macintosh, author="Apple Computer", title = "Inside Macintosh", volume = 3, year = "1985", publisher = "Addison-Wesley, Reading, MA" } @misc { common-windows-manual, author = "Intellicorp, Mountain View, CA", title = "Common Windows Manual", year = "1986" } @misc { composing-uis, author = "M. Linton, J. Vlissides, P. Calder", title = "Composing user interfaces with interviews", publisher = "IEEE Computer, 22(2):8-22, Feb 1989" } @misc { presentation-manager, author = "Scott McKay, William York, Michael McMahon", title = "A presentation manager based on application semantics", published = "In Proceedings of the ACM SIG-GRAPH Symposium on User Interface Software and Technology, pages 141-148. ACM Press, Nov 1989" } @misc { ms-sdk, author = "Microsoft Corporation, Redmond, WA", title = "Microsoft Windows Software Development Kit", year = 1985} @comment { 5^^^ 6\/ } @misc { next-sysman, author = "Next Inc. Redwood City, CA.", title = "Next Preliminary 1.0 System Reference Manual: Concepts", year = 1989 } @misc { motif-guide, author = "Open Software Foundation, Cambridge, MA", title = "OSF/MOTIF Style Guide", year = "1989" } @misc { clos-window-system, author = "Rob Pettengill", title = "The deli window system, A portable, clos based network window system interface", published = "In Proceedings of the First CLOS Users and Implementors Workshop, pages 121— 124, Oct 1988" } @misc { x-toolkit, author = "Ramana Rao and Smokey Wallace", title = "The x toolkit", published = "In Proceedings of the Summer 1987 USENIX Conference. USENIX, 1986" } @misc { silica-paper, author = "Ramana Rao", title = "Silica papers", published = "In Preparation", year = 1991 } @comment { 10^^^ 11\/ } @misc { clim-spec, author = "Scott McKay, Wiliam York", year = 2005, title = "Common lisp interface manager specification", published = "In Preparation" } @misc { x-window-system, author = "R.W. Scheifler, J. Gettys", title = "The x window system. ACM Transactions on Graphics, 5(2)", year = 1986 } @misc { sun-view-prog-guide, author = "Sun Microsystems, Mountain View, CA", title = "Sun-View Programmer's Guide", year = "1986" } @misc { news-tech-over, author = "Sun Microsystems", title = "NeWS Technical Overview", year = "1987" } @misc { open-look-gui, author = "Sun Microsystems, Mountain View, CA", title = "OPEN LOOK Graphical User Interface", year = "1989" } @comment { 15^^^ 16\/ } @misc { prog-ref-manual, author = "Symbolics, Inc", title = "Programmer's Reference Manual Vol 7: Programming the User Interface." } @book { oop-in-cl, title = "Object-Oriented Programmin in Common Lisp", author = "Sonja E. Kenne", year = "1988", isbn = "0-201-17589-4" } @misc { mcclim, author = "McCLIM", title = "A free CLIM implementation", url = "http://common-lisp.net/project/mcclim/" } --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/guided-tour.tex 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/guided-tour.tex 2006/01/26 07:09:35 1.1 \documentclass[twocolumn,a4paper]{article} \usepackage[dvips]{graphicx} \usepackage{color} % Need the color package \usepackage{listings} %\usepackage{epsfig} \title{\Huge A Guided Tour of CLIM, \\ Common Lisp Interface Manager} \author{ 2006 Update \\ Clemens Fruhwirth \texttt{<clemens(a)endorphin.org>} \\ The McCLIM Project \bigskip \\ [603 lines skipped] --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/hello-world.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/hello-world.lisp 2006/01/26 07:09:35 1.1 [637 lines skipped] --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/scheduler.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/scheduler.lisp 2006/01/26 07:09:35 1.1 [743 lines skipped] --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/simple-draw.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/simple-draw.lisp 2006/01/26 07:09:35 1.1 [765 lines skipped] --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/simple-spreadsheet.lisp 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/simple-spreadsheet.lisp 2006/01/26 07:09:35 1.1 [899 lines skipped] --- /project/mcclim/cvsroot/mcclim/docs/guided-tour/techno-dep.fig 2006/01/26 07:09:35 NONE +++ /project/mcclim/cvsroot/mcclim/docs/guided-tour/techno-dep.fig 2006/01/26 07:09:35 1.1 [932 lines skipped]

2 1

[mcclim-cvs] CVS mcclim/docs/guided-tour
by cfruhwirth 26 Jan '06

26 Jan '06

Update of /project/mcclim/cvsroot/mcclim/docs/guided-tour In directory common-lisp:/tmp/cvs-serv22440/guided-tour Log Message: Directory /project/mcclim/cvsroot/mcclim/docs/guided-tour added to the repository

1 0

[mcclim-cvs] CVS mcclim/docs
by cfruhwirth 26 Jan '06

26 Jan '06

Update of /project/mcclim/cvsroot/mcclim/docs In directory common-lisp:/tmp/cvs-serv22101/docs Log Message: Directory /project/mcclim/cvsroot/mcclim/docs added to the repository

1 0

[mcclim-cvs] CVS mcclim
by CVS User afuchs 22 Jan '06

22 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv5587 Modified Files: input-editing.lisp medium.lisp Log Message: Remove the blocks marked #+unicode, and remove #-unicode tags. As clisp includes :unicode on their *features* list, it doesn't make much sense anymore to keep code around that worked only with an experimental branch of cmucl, long ago. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2005/06/22 09:49:15 1.47 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/01/22 21:17:07 1.48 @@ -653,7 +653,7 @@ (if (> nmatches 0) (insert-input input) (beep))) - (cond ((and success (eq mode :complete)) + (cond ((and success (eq mode :complete)) (return-from complete-input (values object success input))) ((activation-gesture-p gesture) --- /project/mcclim/cvsroot/mcclim/medium.lisp 2005/12/01 11:10:55 1.56 +++ /project/mcclim/cvsroot/mcclim/medium.lisp 2006/01/22 21:17:07 1.57 @@ -79,8 +79,6 @@ (defgeneric text-style-family (text-style)) (defgeneric text-style-face (text-style)) (defgeneric text-style-size (text-style)) -#+unicode -(defgeneric text-style-language (text-style)) (defgeneric merge-text-styles (text-style-1 text-style-2)) (defgeneric text-style-ascent (text-style medium)) (defgeneric text-style-descent (text-style medium)) @@ -99,24 +97,13 @@ :reader text-style-face) (size :initarg :text-size :initform :normal - :reader text-style-size) - #+unicode - (language :initarg :text-language - :initform nil - :reader text-style-language))) + :reader text-style-size))) -#-unicode (defmethod make-load-form ((obj standard-text-style) &optional env) (declare (ignore env)) (with-slots (family face size) obj `(make-text-style ',family ',face ',size))) -#+unicode -(defmethod make-load-form ((obj standard-text-style) &optional env) - (declare (ignore env)) - (with-slots (family face size language) obj - `(make-text-style ',family ',face ',size ',language))) - (defun family-key (family) (ecase family ((nil) 0) @@ -148,29 +135,14 @@ ((:smaller) 8) ((:larger) 9)))) -#+unicode -(defun language-key (language) - (ecase language - ((:english nil) 0) - ((:korean) 1))) - -#-unicode (defun text-style-key (family face size) (+ (* 256 (size-key size)) (* 16 (face-key face)) (family-key family))) -#+unicode -(defun text-style-key (family face size &optional (language nil)) - (+ (ash (size-key size) 12) - (ash (language-key language) 8) - (ash (face-key face) 4) - (ash (family-key family) 0))) - (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *text-style-hash-table* (make-hash-table :test #'eql))) -#-unicode (defun make-text-style (family face size) (let ((key (text-style-key family face size))) (declare (type fixnum key)) @@ -181,17 +153,6 @@ :text-face face :text-size size))))) -#+unicode -(defun make-text-style (family face size &optional language) - (let ((key (text-style-key family face size language))) - (declare (type fixnum key)) - (or (gethash key *text-style-hash-table*) - (setf (gethash key *text-style-hash-table*) - (make-instance 'standard-text-style - :text-family family - :text-face face - :text-size size - :text-language language))))) ) ; end eval-when (defmethod print-object ((self text-style) stream) @@ -202,9 +163,7 @@ (style2 standard-text-style)) (and (eql (text-style-family style1) (text-style-family style2)) (eql (text-style-face style1) (text-style-face style2)) - (eql (text-style-size style1) (text-style-size style2)) - #+unicode (eql (text-style-language style1) - (text-style-language style2)))) + (eql (text-style-size style1) (text-style-size style2)))) (defconstant *default-text-style* (make-text-style :fix :roman :normal)) (defconstant *undefined-text-style* *default-text-style*) @@ -232,9 +191,7 @@ (defmethod text-style-components ((text-style standard-text-style)) (values (text-style-family text-style) (text-style-face text-style) - (text-style-size text-style) - #+unicode - (text-style-language text-style))) + (text-style-size text-style))) ;;; Device-Font-Text-Style class @@ -274,7 +231,6 @@ ;;; Text-style utilities -#-unicode (defmethod merge-text-styles (s1 s2) (setq s1 (parse-text-style s1)) (setq s2 (parse-text-style s2)) @@ -296,31 +252,6 @@ (make-text-style family face size)) s1)) -#+unicode -(defmethod merge-text-styles (s1 s2) - (setq s1 (parse-text-style s1)) - (setq s2 (parse-text-style s2)) - (if (and (not (device-font-text-style-p s1)) - (not (device-font-text-style-p s2))) - (let* ((family (or (text-style-family s1) (text-style-family s2))) - (face1 (text-style-face s1)) - (face2 (text-style-face s2)) - (face (if (subsetp '(:bold :italic) (list face1 face2)) - '(:bold :italic) - (or face1 face2))) - (size1 (text-style-size s1)) - (size2 (text-style-size s2)) - (size (case size1 - ((nil) size2) - (:smaller (find-smaller-size size2)) - (:larger (find-larger-size size2)) - (t size1))) - ; v- this is probably wrong, but it requires an idea of which - ; languages include which foreign language support. - (language (or (text-style-language s1) (text-style-language s2)))) - (make-text-style family face size language)) - s1)) - (defun parse-text-style (style) (cond ((text-style-p style) style) ((null style) (make-text-style nil nil nil)) ; ? @@ -392,18 +323,6 @@ (invoke-with-text-style ,medium #',cont (make-text-style nil nil ,size))))) -#+unicode -(defmacro with-text-language ((medium language) &body body) - (declare (type symbol medium)) - (when (eq medium t) (setq medium '*standard-output*)) - (with-gensyms (cont) - `(flet ((,cont (,medium) - ,(declare-ignorable-form* medium) - ,@body)) - (declare (dynamic-extent #',cont)) - (invoke-with-text-style ,medium #',cont - (make-text-style nil nil nil ,language))))) - ;;; MEDIUM class

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by CVS User afuchs 22 Jan '06

22 Jan '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp:/tmp/cvs-serv5587/Backends/CLX Modified Files: medium.lisp port.lisp Log Message: Remove the blocks marked #+unicode, and remove #-unicode tags. As clisp includes :unicode on their *features* list, it doesn't make much sense anymore to keep code around that worked only with an experimental branch of cmucl, long ago. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2005/11/28 13:01:59 1.70 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/01/22 21:17:07 1.71 @@ -36,8 +36,6 @@ (defclass clx-medium (basic-medium) ((gc :initform nil) (picture :initform nil) - #+unicode - (fontset :initform nil :accessor medium-fontset) (buffer :initform nil :accessor medium-buffer))) #+CLX-EXT-RENDER @@ -50,7 +48,6 @@ ;;; secondary methods for changing text styles and line styles -#-unicode (defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) (with-slots (gc) medium (when gc @@ -59,13 +56,6 @@ (setf (xlib:gcontext-font gc) (text-style-to-X-font (port medium) (medium-text-style medium)))))))) -#+unicode -(defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) - (with-slots (fontset) medium - (let ((old-text-style (medium-text-style medium))) - (unless (eq text-style old-text-style) - (setf fontset (text-style-to-X-fontset (port medium) (medium-text-style medium))))))) - ;;; Translate from CLIM styles to CLX styles. (defconstant +cap-shape-map+ '((:butt . :butt) (:square . :projecting) @@ -160,10 +150,7 @@ (xlib:gcontext-dashes gc) (if (eq dashes t) 3 dashes))))) (setf (xlib:gcontext-function gc) boole-1) - #-unicode (setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium))) - #+unicode - (setf (medium-fontset medium) (text-style-to-X-fontset port (medium-text-style medium))) (setf (xlib:gcontext-foreground gc) (X-pixel port ink) (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) ;; Here is a bug with regard to clipping ... ;-( --GB ) @@ -338,11 +325,7 @@ (when mirror (let* ((line-style (medium-line-style ,medium)) (ink (medium-ink ,medium)) - (gc (medium-gcontext ,medium ink)) - #+unicode - (*fontset* (or (medium-fontset ,medium) - (setf (medium-fontset ,medium) - (text-style-to-X-fontset (port ,medium) *default-text-style*))))) + (gc (medium-gcontext ,medium ink))) line-style ink (unwind-protect (progn ,@body) @@ -624,48 +607,24 @@ ;;; ;;; Methods for text styles -#-unicode (defmethod text-style-ascent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (xlib:font-ascent font))) -#+unicode -(defmethod text-style-ascent (text-style (medium clx-medium)) - (let ((fontset (text-style-to-X-fontset (port medium) text-style))) - (fontset-ascent fontset))) - -#-unicode (defmethod text-style-descent (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (xlib:font-descent font))) -#+unicode -(defmethod text-style-descent (text-style (medium clx-medium)) - (let ((fontset (text-style-to-X-fontset (port medium) text-style))) - (fontset-descent fontset))) - -#-unicode (defmethod text-style-height (text-style (medium clx-medium)) (let ((font (text-style-to-X-font (port medium) text-style))) (+ (xlib:font-ascent font) (xlib:font-descent font)))) -#+unicode -(defmethod text-style-height (text-style (medium clx-medium)) - (let ((fontset (text-style-to-X-fontset (port medium) text-style))) - (fontset-height fontset))) - -#-unicode (defmethod text-style-character-width (text-style (medium clx-medium) char) (xlib:char-width (text-style-to-X-font (port medium) text-style) (char-code char))) -#+unicode -(defmethod text-style-character-width (text-style (medium clx-medium) char) - (fontset-point-width (char-code char) (text-style-to-X-fontset (port medium) text-style))) - (defmethod text-style-width (text-style (medium clx-medium)) (text-style-character-width text-style medium #\m)) -#-unicode (defun translate (src src-start src-end afont dst dst-start) ;; This is for replacing the clx-translate-default-function ;; who does'nt know about accentated characters because @@ -706,88 +665,6 @@ (return i) (setf (aref dst j) elt)))))) -; Yes, the following is a nasty hack. -; It's just a proof of concept, I'll try not to commit it :] -; If it does get committed, it shouldn't affect anyone much... - -#+unicode -(defun translate (source source-start source-end initial-font destination destination-start) - ; do the first character especially - (let* ((code (char-code (char source source-start))) - (result (fontset-point code))) - (if result - (destructuring-bind ((range-start . range-stop) font translator) result - (if (not (eq font initial-font)) - ; may need to change fonts immediately: - (values source-start font) - ; otherwise, lets finish the job... - (multiple-value-bind (result success) (funcall translator code) - (setf (elt destination destination-start) result) - (do ((src (+ source-start 1) (+ src 1)) - (dst (+ destination-start 1) (+ dst 1))) - ((>= src source-end) - ; we finished - (values src nil)) - (let* ((code (char-code (char source src)))) - (if (<= range-start code range-stop) - (multiple-value-bind (result success) (funcall translator code) - (setf (elt destination dst) result)) - ; wasn't in the range... need to switch - (let ((new (fontset-point code))) - (if new - (destructuring-bind ((range-start . range-stop) font translator) new - (return (values src font))) - (return (values src nil)))))))))) - (values source-start nil)))) - -#+unicode -(in-package :external-format) - -#+unicode -(defun ascii-code-to-font-index (code) - (values code (<= #x00 code #x7f))) - -#+unicode -(defun ksc5601-code-to-font-index (wc) - (labels ((illegal-sequence () - (error "ksc5601-wctomb")) - (summary-of (array index) - (values (aref array index 0) - (aref array index 1)))) - - (multiple-value-bind (indx used) - (cond - ((<= #x0000 wc #x045f) - (summary-of ksc5601-uni2indx-page00 (ash wc -4))) - ((<= #x2000 wc #x266f) - (summary-of ksc5601-uni2indx-page20 (- (ash wc -4) #x200))) - ((<= #x3000 wc #x33df) - (summary-of ksc5601-uni2indx-page30 (- (ash wc -4) #x300))) - ((<= #x4e00 wc #x9f9f) - (summary-of ksc5601-uni2indx-page4e (- (ash wc -4) #x4e0))) - ((<= #xac00 wc #xd79f) - (summary-of ksc5601-uni2indx-pageac (- (ash wc -4) #xac0))) - ((<= #xf900 wc #xfa0f) - (summary-of ksc5601-uni2indx-pagef9 (- (ash wc -4) #xf90))) - ((<= #xff00 wc #xffef) - (summary-of ksc5601-uni2indx-pageff (- (ash wc -4) #xff0))) - (t - (illegal-sequence))) - (let ((i (logand wc #x0f))) - (if (/= 0 (logand used (ash 1 i))) - (let* ((used (logand used (- (ash 1 i) 1))) - (used (+ (logand used #x5555) (ash (logand used #xaaaa) -1))) - (used (+ (logand used #x3333) (ash (logand used #xcccc) -2))) - (used (+ (logand used #x0f0f) (ash (logand used #xf0f0) -4))) - (used (+ (logand used #x00ff) (ash used -8))) - (c (aref ksc5601-2charset (+ indx used)))) - c) - (illegal-sequence)))))) - -#+unicode -(in-package :clim-clx) - -#-unicode (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) (setf string (make-string 1 :initial-element string))) @@ -825,7 +702,6 @@ direction first-not-done)) (values width (+ ascent descent) width 0 ascent)) )))))) ) -#-unicode (defmethod climi::text-bounding-rectangle* ((medium clx-medium) string &key text-style (start 0) end) (when (characterp string) @@ -866,82 +742,8 @@ ;; * font-ascent / ascent (values left (- font-ascent) right font-descent))))))))) -#+unicode -(defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) - (when (characterp string) - (setf string (make-string 1 :initial-element string))) - (unless end (setf end (length string))) - (unless text-style (setf text-style (medium-text-style medium))) - (let* ((xfontset (text-style-to-X-fontset (port medium) text-style)) - (default-font (fontset-default-font xfontset))) - (cond ((= start end) - (values 0 0 0 0 0)) - (t - (let ((position-newline (position #\newline string :start start :end end))) - (cond ((not (null position-newline)) - (multiple-value-bind (width ascent descent left right - font-ascent font-descent direction - first-not-done) - (let ((*fontset* xfontset)) - (xlib:text-extents default-font string - :start start :end position-newline - :translate #'translate)) - (declare (ignorable left right - font-ascent font-descent - direction first-not-done)) - (multiple-value-bind (w h x y baseline) - (text-size medium string :text-style text-style - :start (1+ position-newline) :end end) - (values (max w width) (+ ascent descent h) - x (+ ascent descent y) (+ ascent descent baseline))))) - (t - (multiple-value-bind (width ascent descent left right - font-ascent font-descent direction - first-not-done) - (let ((*fontset* xfontset)) - (xlib:text-extents default-font string - :start start :end end - :translate #'translate)) - (declare (ignorable left right - font-ascent font-descent - direction first-not-done)) - (values width (+ ascent descent) width 0 ascent)) )))))) ) -#-unicode -(defmethod medium-draw-text* ((medium clx-medium) string x y - start end - align-x align-y - toward-x toward-y transform-glyphs) - (declare (ignore toward-x toward-y transform-glyphs)) - (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) - x y) - (with-clx-graphics (medium) - (when (characterp string) - (setq string (make-string 1 :initial-element string))) - (when (null end) (setq end (length string))) - (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) - (text-size medium string :start start :end end) - (declare (ignore x-cursor y-cursor)) - (unless (and (eq align-x :left) (eq align-y :baseline)) - (setq x (- x (ecase align-x - (:left 0) - (:center (round text-width 2)) - (:right text-width)))) - (setq y (ecase align-y - (:top (+ y baseline)) - (:center (+ y baseline (- (floor text-height 2)))) - (:baseline y) - (:bottom (+ y baseline (- text-height))))))) - (let ((x (round-coordinate x)) - (y (round-coordinate y))) - (when (and (<= #x-8000 x #x7FFF) - (<= #x-8000 y #x7FFF)) - (multiple-value-bind (halt width) - (xlib:draw-glyphs mirror gc x y string - :start start :end end - :translate #'translate))))))) -#+unicode (defmethod medium-draw-text* ((medium clx-medium) string x y start end align-x align-y @@ -973,7 +775,6 @@ (multiple-value-bind (halt width) (xlib:draw-glyphs mirror gc x y string :start start :end end - :size 16 :translate #'translate))))))) (defmethod medium-buffering-output-p ((medium clx-medium)) --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/01/17 16:57:47 1.118 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/01/22 21:17:07 1.119 @@ -937,7 +937,6 @@ (defvar *fontset* nil) -#-unicode (defmethod text-style-mapping ((port clx-port) text-style &optional character-set) (declare (ignore character-set)) @@ -972,96 +971,6 @@ (open-font (clx-port-display port) font-name))) font-name)))))) -#+unicode -(defun build-english-font-name (text-style) - (multiple-value-bind (family face size language) - (text-style-components text-style) - (destructuring-bind (family-name face-table) - (if (stringp family) - (list family *clx-text-faces*) - (or (getf *clx-text-family+face-map* family) - (getf *clx-text-family+face-map* :fix))) - (let* ((face-name (if (stringp face) - face - (or (getf face-table - (if (listp face) - (intern (format nil "~A-~A" - (symbol-name (first face)) - (symbol-name (second face))) - :keyword) - face)) - (getf *clx-text-faces* :roman)))) - (size-number (if (numberp size) - (round size) - (or (getf *clx-text-sizes* size) - (getf *clx-text-sizes* :normal)))) - (font-name (format nil "-~A-~A-*-*-~D-*-*-*-*-*-*-*" - family-name face-name size-number))) - font-name)))) - -#+unicode -(defun build-korean-font-name (text-style) - (multiple-value-bind (family face size language) - (text-style-components text-style) - (let* ((face (if (equal face '(:bold :italic)) :bold-italic face)) - (font (case family - ((:fix nil) - (case face - ((:roman nil) "baekmuk-dotum-medium-r") - ((:bold) "baekmuk-dotum-bold-r") - ((:italic) "baekmuk-dotum-medium-r") - ((:bold-italic) "baekmuk-dotum-bold-r"))) - ((:serif) - (case face - ((:roman nil) "baekmuk-batang-medium-r") - ((:bold) "baekmuk-batang-bold-r") - ((:italic) "baekmuk-batang-medium-r") - ((:bold-italic) "baekmuk-batang-bold-r"))) - ((:sans-serif) - (case face - ((:roman nil) "baekmuk-gulim-medium-r") - ((:bold) "baekmuk-gulim-bold-r") - ((:italic) "baekmuk-gulim-medium-r") - ((:bold-italic) "baekmuk-gulim-bold-r"))))) - (size-number (if (numberp size) - (round size) - (or (getf *clx-text-sizes* size) - (getf *clx-text-sizes* :normal))))) - (format nil "-~A-*-*-~D-*-*-*-*-*-ksx1001.1997-*" font size-number)))) - -; this needs much refactoring... FIXME -#+unicode -(defmethod text-style-mapping ((port clx-port) text-style - &optional character-set) - (declare (ignore character-set)) - - (let ((table (port-text-style-mappings port))) - (or (car (gethash text-style table)) - (multiple-value-bind (family face size language) - (text-style-components text-style) - (let* ((display (clx-port-display port)) - (fontset (case language - ((nil :english) - (let* ((font-name (build-english-font-name text-style)) - (font (xlib:open-font display font-name))) - (make-fontset font-name - (0 255 font #'external-format::ascii-code-to-font-index)))) - ((:korean) - (let* ((english-font-name (build-english-font-name text-style)) - (english-font (xlib:open-font display english-font-name)) - (korean-font-name (build-korean-font-name text-style)) - (korean-font (xlib:open-font display korean-font-name))) - (make-fontset korean-font-name - (0 255 english-font - #'external-format::ascii-code-to-font-index) - (#xAC00 #xD7A3 korean-font - #'external-format::ksc5601-code-to-font-index) - (#x4E00 #x9FA5 korean-font - #'external-format::ksc5601-code-to-font-index))))))) - (setf (gethash text-style table) - (cons (fontset-name fontset) fontset)) - (fontset-name fontset)))))) - (defmethod (setf text-style-mapping) (font-name (port clx-port) (text-style text-style) &optional character-set) @@ -1070,38 +979,20 @@ (cons font-name (open-font (clx-port-display port) font-name))) font-name) -#-unicode (defun text-style-to-X-font (port text-style) (let ((text-style (parse-text-style text-style))) (text-style-mapping port text-style) (cdr (gethash text-style (port-text-style-mappings port))))) -#+unicode -(defun text-style-to-X-fontset (port text-style) - (let ((text-style (parse-text-style text-style))) - (text-style-mapping port text-style) - (cdr (gethash text-style (port-text-style-mappings port))))) - -#-unicode (defmethod port-character-width ((port clx-port) text-style char) (let* ((font (text-style-to-X-font port text-style)) (width (xlib:char-width font (char-code char)))) width)) -#+unicode -(defmethod port-character-width ((port clx-port) text-style char) - (fontset-point-width (char-code char) (text-style-to-X-fontset port text-style))) - -#-unicode (defmethod port-string-width ((port clx-port) text-style string &key (start 0) end) (xlib:text-width (text-style-to-X-font port text-style) string :start start :end end)) -#+unicode ; this requires a translator and so on. -(defmethod port-string-width ((port clx-port) text-style string &key (start 0) end) - (let ((*fontset* (text-style-to-X-fontset port text-style))) - (xlib:text-width nil string :start start :end end :translator #'translate))) - (defmethod X-pixel ((port clx-port) color) (let ((table (slot-value port 'color-table))) (or (gethash color table)

1 0

[mcclim-cvs] CVS update: mcclim/decls.lisp mcclim/presentation-defs.lisp mcclim/setf-star.lisp mcclim/transforms.lisp
by tmoore＠common-lisp.net 18 Jan '06

18 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv4733 Modified Files: decls.lisp presentation-defs.lisp setf-star.lisp transforms.lisp Log Message: Changed DEFGENERIC* and DEFMETHOD* to use a private name for the generic function defined. This avoids warnings from some systems that don't like having a defsetf macro and a setf function for the same place. This is an invasive change; *RECOMPILE YOUR FILES*. Cleaned up some duplicate definitions in decls.lisp, transforms.lisp. Integrated Troels Henriksen's patch for :insert-default in ACCEPT. Date: Wed Jan 18 08:07:36 2006 Author: tmoore Index: mcclim/decls.lisp diff -u mcclim/decls.lisp:1.34 mcclim/decls.lisp:1.35 --- mcclim/decls.lisp:1.34 Tue Dec 6 07:40:04 2005 +++ mcclim/decls.lisp Wed Jan 18 08:07:36 2006 @@ -99,9 +99,6 @@ (defgeneric rectangle-height (rectangle)) (defgeneric rectangle-size (rectangle)) - -(defgeneric transform-region (transformation region)) - ;;; 5.3.2 Composition of Transformations (defgeneric compose-transformations (transformation1 transformation2)) Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.49 mcclim/presentation-defs.lisp:1.50 --- mcclim/presentation-defs.lisp:1.49 Wed Jan 4 03:45:35 2006 +++ mcclim/presentation-defs.lisp Wed Jan 18 08:07:36 2006 @@ -810,7 +810,7 @@ (additional-activation-gestures nil additional-activations-p) (delimiter-gestures nil delimitersp) (additional-delimiter-gestures nil additional-delimiters-p)) - (declare (ignore provide-default insert-default history active-p + (declare (ignore provide-default history active-p prompt prompt-mode display-default query-identifier)) (when (and defaultp (not default-type-p)) @@ -830,6 +830,13 @@ (declare (ignore stream)) (funcall cont)))) (with-input-position (stream) ; support for calls to replace-input + (when insert-default + ;; Insert the default value to the input stream. It should + ;; become fully keyboard-editable. + (presentation-replace-input stream + default + default-type + view)) (setf (values sensitizer-object sensitizer-type) (with-input-context (type) (object object-type event options) @@ -846,10 +853,10 @@ (setq accept-results (multiple-value-list (if defaultp - (funcall-presentation-generic-function - accept type stream view - :default default - :default-type default-type) + (funcall-presentation-generic-function + accept type stream view + :default default + :default-type default-type) (funcall-presentation-generic-function accept type stream view)))) ;; User entered activation or delimeter @@ -897,6 +904,7 @@ &key (default nil defaultp) (default-type type) + (insert-default nil) (prompt t) (prompt-mode :normal) (display-default prompt) @@ -914,9 +922,12 @@ *recursive-accept-p* (describe-presentation-type type nil nil)) prompt)) - (default-string (if (and defaultp display-default) - (present-to-string default default-type) - nil))) + ;; Don't display the default in the prompt if it is to be + ;; inserted into the input stream. + (default-string (and defaultp + (not insert-default) + display-default + (present-to-string default default-type)))) (cond ((null prompt) nil) (t Index: mcclim/setf-star.lisp diff -u mcclim/setf-star.lisp:1.2 mcclim/setf-star.lisp:1.3 --- mcclim/setf-star.lisp:1.2 Fri Mar 21 15:36:59 2003 +++ mcclim/setf-star.lisp Wed Jan 18 08:07:36 2006 @@ -23,6 +23,16 @@ (defun setf-name-p (name) (and (listp name) (eq (car name) 'setf))) +;;; Many implementations complain if a defsetf definition and a setf function +;;; exist for the same place. Time to stop fighting that... + +(defun make-setf*-gfn-name (function-name) + (let* ((name-sym (cadr function-name))) + `(setf ,(intern (format nil ".~A-~A." + (symbol-name name-sym) + (symbol-name '#:star)) + (symbol-package name-sym))))) + (defmacro defgeneric* (fun-name lambda-list &body options) "Defines a SETF* generic function. FUN-NAME is a SETF function name. The last argument is the single argument to the function in a @@ -32,16 +42,17 @@ (error "~S is not a valid name for a SETF* generic function." fun-name)) (let ((setf-name (cadr fun-name)) (args (butlast lambda-list)) - (place (car (last lambda-list)))) + (place (car (last lambda-list))) + (gf (make-setf*-gfn-name fun-name))) `(progn (defsetf ,setf-name (,place) ,args - `(funcall #',',fun-name ,,@args ,,place)) - (defgeneric ,fun-name ,lambda-list ,@options)))) + `(funcall #',',gf ,,@args ,,place)) + (defgeneric ,gf ,lambda-list ,@options)))) (defmacro defmethod* (name &body body) "Defines a SETF* method. NAME is a SETF function name. Otherwise, like DEFMETHOD except there must exist a corresponding DEFGENERIC* form." (unless (setf-name-p name) (error "~S is not a valid name for a SETF* generic function." name)) - `(defmethod ,name ,@body)) + `(defmethod ,(make-setf*-gfn-name name) ,@body)) Index: mcclim/transforms.lisp diff -u mcclim/transforms.lisp:1.31 mcclim/transforms.lisp:1.32 --- mcclim/transforms.lisp:1.31 Fri Dec 16 10:42:15 2005 +++ mcclim/transforms.lisp Wed Jan 18 08:07:36 2006 @@ -4,7 +4,7 @@ ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: transforms.lisp,v 1.31 2005/12/16 16:42:15 rgoldman Exp $ +;;; $Id: transforms.lisp,v 1.32 2006/01/18 14:07:36 tmoore Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by @@ -435,9 +435,6 @@ ;;(defmacro with-local-coordinates ((medium &optional x y) &body body)) -- what are local coordinates? ;;(defmacro with-first-quadrant-coordinates ((medium &optional x y) &body body)) - -;;(defgeneric transform-region (transformation region)) - (defmacro with-identity-transformation ((medium) &body body) ;; I believe this should set the medium transformation to the identity ;; transformation. To use WITH-DRAWING-OPTIONS which concatenates the the

1 0

[mcclim-cvs] CVS update: mcclim/system.lisp
by tmoore＠common-lisp.net 17 Jan '06

17 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv9628 Modified Files: system.lisp Log Message: Split up scigraph defsystem so system.lisp will load in sbcl Date: Tue Jan 17 16:48:39 2006 Author: tmoore Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.111 mcclim/system.lisp:1.112 --- mcclim/system.lisp:1.111 Mon Jan 31 23:35:29 2005 +++ mcclim/system.lisp Tue Jan 17 16:48:39 2006 @@ -216,9 +216,8 @@ "Goatee/goatee-test" "Examples/accepting-values") - -(clim-defsystem (:scigraph :depends-on (:clim #+clx :clim-looks)) - ;; The DWIM part of SCIGRAPH +;;; The DWIM part of SCIGRAPH +(clim-defsystem (:scigraph-dwim :depends-on (:clim #+clx :clim-looks)) "Apps/Scigraph/dwim/package" "Apps/Scigraph/dwim/feature-case" "Apps/Scigraph/dwim/macros" @@ -227,8 +226,10 @@ "Apps/Scigraph/dwim/present" "Apps/Scigraph/dwim/extensions" "Apps/Scigraph/dwim/wholine" - "Apps/Scigraph/dwim/export" - ;; The Scigraph part + "Apps/Scigraph/dwim/export") + +;;; The Scigraph part +(clim-defsystem (:scigraph :depends-on (:scigraph-dwim)) "Apps/Scigraph/scigraph/package" "Apps/Scigraph/scigraph/copy" "Apps/Scigraph/scigraph/dump"

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by tmoore＠common-lisp.net 17 Jan '06

17 Jan '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp:/tmp/cvs-serv26111/Backends/CLX Modified Files: port.lisp Log Message: Clean up arg list of event-handler Date: Tue Jan 17 10:57:47 2006 Author: tmoore Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.117 mcclim/Backends/CLX/port.lisp:1.118 --- mcclim/Backends/CLX/port.lisp:1.117 Fri Jan 13 05:05:06 2006 +++ mcclim/Backends/CLX/port.lisp Tue Jan 17 10:57:47 2006 @@ -644,13 +644,11 @@ ;; pointer-event-buttons slot to pointer events. -- moore ;; -(defun event-handler (&rest event-slots - &key display window event-key code state mode time +(defun event-handler (&key display window event-key code state mode time type width height x y root-x root-y data override-redirect-p send-event-p hint-p target property requestor selection &allow-other-keys) - (declare (ignorable event-slots)) (declare (special *clx-port*)) (let ((sheet (and window (port-lookup-sheet *clx-port* window))))

1 0

[mcclim-cvs] CVS update: mcclim/input.lisp
by cfruhwirth＠common-lisp.net 16 Jan '06

16 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp:/tmp/cvs-serv25595 Modified Files: input.lisp Log Message: Remove superfluous closing-parenthesis. Date: Mon Jan 16 07:16:38 2006 Author: cfruhwirth Index: mcclim/input.lisp diff -u mcclim/input.lisp:1.34 mcclim/input.lisp:1.35 --- mcclim/input.lisp:1.34 Fri Jan 13 10:51:03 2006 +++ mcclim/input.lisp Mon Jan 16 07:16:38 2006 @@ -559,4 +559,4 @@ ((eq button +pointer-wheel-left+) (scroll-sheet sheet 0 -1)) ((eq button +pointer-wheel-right+) (scroll-sheet sheet 0 1)) (t (call-next-method)))) ; not a scroll wheel button - (call-next-method)))) ; no viewport + (call-next-method))) ; no viewport

1 0

[mcclim-cvs] CVS update: mcclim/input.lisp
by cfruhwirth＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv7567 Modified Files: input.lisp Log Message: Rewrite dispatch-event for mouse-wheel-scroll-mixin to work with left and right scrolling wheel buttons. Date: Fri Jan 13 17:51:03 2006 Author: cfruhwirth Index: mcclim/input.lisp diff -u mcclim/input.lisp:1.33 mcclim/input.lisp:1.34 --- mcclim/input.lisp:1.33 Fri Jul 1 14:59:39 2005 +++ mcclim/input.lisp Fri Jan 13 17:51:03 2006 @@ -535,23 +535,28 @@ (defmethod scroll-quantum (pane) 10) +(defun scroll-sheet (sheet vertical horizontal) + (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet) + (let ((viewport-height (- vy1 vy0)) + (viewport-width (- vx1 vx0)) + (delta (* *mouse-scroll-distance* + (scroll-quantum sheet)))) + ;; The coordinates (x,y) of the new upper-left corner of the viewport + ;; must be "sx0 < x < sx1 - viewport-width" and + ;; "sy0 < y < sy1 - viewport-height" + (scroll-extent sheet + (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal)))) + (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical))))))))) + (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin) (event pointer-button-press-event)) - (let ((viewport (pane-viewport sheet)) - (button (pointer-event-button event)) - (dy (* *mouse-scroll-distance* - (scroll-quantum sheet)))) - (if (and viewport - (or (eql button +pointer-wheel-up+) - (eql button +pointer-wheel-down+))) - (multiple-value-bind (x0 y0 x1 y1) - (bounding-rectangle* (pane-viewport-region sheet)) - (declare (ignore x1)) - (multiple-value-bind (sx0 sy0 sx1 sy1) - (bounding-rectangle* (sheet-region sheet)) - (declare (ignore sx0 sx1)) - (let ((height (- y1 y0))) - (scroll-extent sheet x0 (if (eql button +pointer-wheel-up+) - (max sy0 (- y0 dy)) - (- (min sy1 (+ y1 dy)) height)))))) - (call-next-method)))) \ No newline at end of file + (if (pane-viewport sheet) + (let ((button (pointer-event-button event))) + (cond + ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0)) + ((eq button +pointer-wheel-down+) (scroll-sheet sheet 1 0)) + ((eq button +pointer-wheel-left+) (scroll-sheet sheet 0 -1)) + ((eq button +pointer-wheel-right+) (scroll-sheet sheet 0 1)) + (t (call-next-method)))) ; not a scroll wheel button + (call-next-method)))) ; no viewport

1 0

[mcclim-cvs] CVS update: mcclim/recording.lisp
by cfruhwirth＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv18663 Modified Files: recording.lisp Log Message: %handle-repaint derives the bounding rectangle for region. There are two cases where region does not participate in the bounding rectangle protocol: +everywhere+ and +nowhere+, the only two regions in the unbound region class. For +everywhere+, fallback to the bounding rectangle of sheet. For +nowhere+, ignore repaint. Date: Fri Jan 13 13:18:11 2006 Author: cfruhwirth Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.120 mcclim/recording.lisp:1.121 --- mcclim/recording.lisp:1.120 Thu Dec 1 12:10:55 2005 +++ mcclim/recording.lisp Fri Jan 13 13:17:55 2006 @@ -2237,11 +2237,14 @@ (defun %handle-repaint (stream region) (when (output-recording-stream-p stream) - (let ((region (bounding-rectangle region))) - (with-bounding-rectangle* (x1 y1 x2 y2) region - (with-output-recording-options (stream :record nil) - (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+))) - (stream-replay stream region)))) + (unless (region-equal region +nowhere+) ; ignore repaint requests for +nowhere+ + (let ((region (if (region-equal region +everywhere+) + (sheet-region stream) ; fallback to the sheet's region for +everwhere+ + (bounding-rectangle region)))) + (with-bounding-rectangle* (x1 y1 x2 y2) region + (with-output-recording-options (stream :record nil) + (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+))) + (stream-replay stream region))))) (defmethod handle-repaint ((stream output-recording-stream) region) (%handle-repaint stream region))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by cfruhwirth＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv12046 Modified Files: port.lisp Log Message: Enable :pointer-motion in default event mask for realize-mirror-aux. This unbreaks tracking-pointer's pointer-motion for all regular sheets. Previously, it only worked for clim-stream-pane, because clim-stream-pane overrode the defaults. This will cause additional traffic between the X11 server and CLIM, however the CLIM spec does not provide a way to selectively enable or disable events (only total muting is possible). Therefore, we must shove all events to a sheet as we have no way to find out if an event is handled or not. Date: Fri Jan 13 12:05:06 2006 Author: cfruhwirth Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.116 mcclim/Backends/CLX/port.lisp:1.117 --- mcclim/Backends/CLX/port.lisp:1.116 Thu Jan 12 22:08:06 2006 +++ mcclim/Backends/CLX/port.lisp Fri Jan 13 12:05:06 2006 @@ -345,8 +345,8 @@ :button-press :button-release :enter-window :leave-window :structure-notify - ;:pointer-motion - :button-motion))) + :pointer-motion + :button-motion))) (when (null (port-lookup-mirror port sheet)) (update-mirror-geometry sheet) (let* ((desired-color (typecase sheet

1 0

[mcclim-cvs] CVS update: mcclim/commands.lisp
by cfruhwirth＠common-lisp.net 13 Jan '06

13 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv4901 Modified Files: commands.lisp Log Message: According to the CLIM Spec, Chapter 26, accepting-values must be supplied with accept forms that either have unique query-identifiers or unique prompts (query-identifier is derived from prompt if query-id is missing). When the partial command parser is called for commands that have two arguments with the same type, two identical prompts are generated. That is not allowed. Fix by generating a unique query-identifier via gensym in accept-form-for-argument-partial. Date: Fri Jan 13 10:26:21 2006 Author: cfruhwirth Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.56 mcclim/commands.lisp:1.57 --- mcclim/commands.lisp:1.56 Thu Dec 1 12:10:54 2005 +++ mcclim/commands.lisp Fri Jan 13 10:26:21 2006 @@ -639,6 +639,7 @@ ,command-arg)) else if (member key accept-keys :test #'eq) append `(,key ,val)))) + (setq args (append args `(:query-identifier ',(gensym "COMMAND-PROMPT-ID")))) (if (member :default args :test #'eq) `(accept ,ptype :stream ,stream ,@args) `(if (eq ,original-command-arg *unsupplied-argument-marker*)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by cfruhwirth＠common-lisp.net 12 Jan '06

12 Jan '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv12975 Modified Files: port.lisp Log Message: Add handler-case for destroy-port to handle stream-errors thrown by xlib:close-display. Required to destroy ports with a connection already closed/reseted by the X server (xkilled client or network drop outs) Date: Thu Jan 12 22:08:08 2006 Author: cfruhwirth Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.115 mcclim/Backends/CLX/port.lisp:1.116 --- mcclim/Backends/CLX/port.lisp:1.115 Wed Jan 11 09:30:56 2006 +++ mcclim/Backends/CLX/port.lisp Thu Jan 12 22:08:06 2006 @@ -536,7 +536,10 @@ (xlib:unmap-window (sheet-direct-mirror mirror)) ) (defmethod destroy-port :before ((port clx-port)) - (xlib:close-display (clx-port-display port))) + (handler-case + (xlib:close-display (clx-port-display port)) + (stream-error () + (xlib:close-display (clx-port-display port) :abort t)))) (defmethod port-motion-hints ((port clx-port) (sheet mirrored-sheet-mixin)) (let ((event-mask (xlib:window-event-mask (sheet-direct-mirror sheet))))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by ahefner＠common-lisp.net 11 Jan '06

11 Jan '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv1768/Backends/CLX Modified Files: port.lisp Log Message: Add wheel left/right constants. TODO: Support left/right scrolling of panes (I don't have an appropriate input device to test this, so I leave it for someone else). Date: Wed Jan 11 09:30:57 2006 Author: ahefner Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.114 mcclim/Backends/CLX/port.lisp:1.115 --- mcclim/Backends/CLX/port.lisp:1.114 Mon Nov 28 15:21:45 2005 +++ mcclim/Backends/CLX/port.lisp Wed Jan 11 09:30:56 2006 @@ -571,11 +571,12 @@ +pointer-middle-button+ +pointer-right-button+ +pointer-wheel-up+ - +pointer-wheel-down+))) - (if (and (> code 0) - (<= code (1+ (length button-mapping)))) - (aref button-mapping (1- code)) - nil))) + +pointer-wheel-down+ + +pointer-wheel-left+ + +pointer-wheel-right+))) + (and (> code 0) + (<= code (1+ (length button-mapping))) + (aref button-mapping (1- code))))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, ;; section 4.1.5:

1 0

[mcclim-cvs] CVS update: mcclim/events.lisp mcclim/package.lisp
by ahefner＠common-lisp.net 11 Jan '06

11 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv1768 Modified Files: events.lisp package.lisp Log Message: Add wheel left/right constants. TODO: Support left/right scrolling of panes (I don't have an appropriate input device to test this, so I leave it for someone else). Date: Wed Jan 11 09:30:56 2006 Author: ahefner Index: mcclim/events.lisp diff -u mcclim/events.lisp:1.26 mcclim/events.lisp:1.27 --- mcclim/events.lisp:1.26 Thu Oct 14 08:30:11 2004 +++ mcclim/events.lisp Wed Jan 11 09:30:55 2006 @@ -304,6 +304,8 @@ (defconstant +pointer-right-button+ #x04) (defconstant +pointer-wheel-up+ #x08) (defconstant +pointer-wheel-down+ #x10) +(defconstant +pointer-wheel-left+ #x20) +(defconstant +pointer-wheel-right+ #x40) (defconstant +shift-key+ #x0100) (defconstant +control-key+ #x0200) Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.50 mcclim/package.lisp:1.51 --- mcclim/package.lisp:1.50 Fri Aug 12 04:26:00 2005 +++ mcclim/package.lisp Wed Jan 11 09:30:55 2006 @@ -1638,6 +1638,8 @@ (:export #:+pointer-wheel-up+ #:+pointer-wheel-down+ + #:+pointer-wheel-left+ + #:+pointer-wheel-right+ #:sheet-pointer-cursor) ;;; x11 color names - some are not in the spec - mikemac

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by tmoore＠common-lisp.net 04 Jan '06

04 Jan '06

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv32753 Modified Files: presentation-defs.lisp Log Message: fix behavior of :allow-sensitive-inferiors in with-output-as-presentation. It was disabling the current presentation as well as the inferiors. Date: Wed Jan 4 10:45:36 2006 Author: tmoore Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.48 mcclim/presentation-defs.lisp:1.49 --- mcclim/presentation-defs.lisp:1.48 Fri Sep 2 13:36:48 2005 +++ mcclim/presentation-defs.lisp Wed Jan 4 10:45:35 2006 @@ -280,24 +280,23 @@ (with-gensyms (record-arg continuation) (with-keywords-removed (key-args (:record-type :allow-sensitive-inferiors)) - `(let ((*allow-sensitive-inferiors* - (if *allow-sensitive-inferiors* - ,allow-sensitive-inferiors - nil))) - (flet ((,continuation () - ,@decls - ,@with-body)) - (declare (dynamic-extent #'continuation)) - (if (and (output-recording-stream-p ,stream) - *allow-sensitive-inferiors*) - (with-new-output-record - (,stream ,record-type ,record-arg - :object ,object - :type (expand-presentation-type-abbreviation - ,type) - ,@key-args) - (,continuation)) - (,continuation)))))))) + `(flet ((,continuation () + ,@decls + ,@with-body)) + (declare (dynamic-extent #'continuation)) + (if (and (output-recording-stream-p ,stream) + *allow-sensitive-inferiors*) + (with-new-output-record + (,stream ,record-type ,record-arg + :object ,object + :type (expand-presentation-type-abbreviation + ,type) + ,@key-args) + (let ((*allow-sensitive-inferiors* + ,allow-sensitive-inferiors)) + (,continuation))) + (,continuation))))))) + (defun present (object &optional (type (presentation-type-of object)) &key @@ -337,9 +336,10 @@ (allow-sensitive-inferiors t) (sensitive t) (record-type 'standard-presentation)) - (let ((*allow-sensitive-inferiors* (if *allow-sensitive-inferiors* - sensitive - nil))) + ;; *allow-sensitive-inferiors* controls whether or not + ;; with-output-as-presentation will emit a presentation + (let ((*allow-sensitive-inferiors* (and *allow-sensitive-inferiors* + sensitive))) (with-output-as-presentation (stream object type :view view :modifier modifier

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/icons.lisp
by mretzlaff＠common-lisp.net 01 Jan '06

01 Jan '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv22828 Modified Files: icons.lisp Log Message: The old version was probably not portable, it's now using the "portablized" version LIST-DIRECTORY that is defined in util.lisp. More important a wild pathname will be created first. (This actually has bitten me: I've created a core image that includes my File Selector that uses the functions of the Clim Listener to display directories. This image was going to be run on other computers that have no mcclim sources installed (not to speak about installed in equivalent directories). As PRECACHE-ICONS did not work and the icons for which there are no separate DEFICON constructs have not been cached, it tried to load the icon "up-folder.xpm" in COM-SHOW-DIRECTORY. . .) By the way, what do you think about getting rid of the pathname functions in util.lisp and depend on CL-FAD instead (the, so to speak, maintained version of Peter Seibel's :com.gigamonkeys.pathnames package)? Why shouldn't we use a nice library if it already exists? (In addition to this, the File Selector uses it as well -- particularly cl-fad:pathname-as-directory --, although it is not yet commited to the CVS.) Date: Sun Jan 1 11:14:55 2006 Author: mretzlaff Index: mcclim/Apps/Listener/icons.lisp diff -u mcclim/Apps/Listener/icons.lisp:1.3 mcclim/Apps/Listener/icons.lisp:1.4 --- mcclim/Apps/Listener/icons.lisp:1.3 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/icons.lisp Sun Jan 1 11:14:50 2006 @@ -64,7 +64,8 @@ (defun precache-icons () (let ((pathnames (remove-if #'directoryp - (directory (strip-filespec *icon-path*))))) + (list-directory (gen-wild-pathname + (strip-filespec *icon-path*)))))) (dolist (pn pathnames) (standard-icon (namestring (make-pathname :name (pathname-name pn) :type (pathname-type pn)))))))

1 0