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