mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 24 May '08

24 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9861/Drei Modified Files: lisp-syntax.lisp Log Message: Random fixes for Lisp syntax highlighting. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/05/03 09:12:25 1.77 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/05/24 11:55:41 1.78 @@ -1809,10 +1809,13 @@ ;; We don't use `form-to-object' as we want to retrieve information ;; even about symbol that are not interned. (multiple-value-bind (symbol package) - (parse-symbol (form-string syntax symbol-form) :package *package*) + (parse-symbol (form-string syntax symbol-form) + :package (package-at-mark syntax (start-offset symbol-form))) (setf (keyword-symbol-p symbol-form) (eq package +keyword-package+) - (macroboundp symbol-form) (or (special-operator-p symbol) - (macro-function symbol)) + (macroboundp symbol-form) (when (eq (first-form (children (parent symbol-form))) + symbol-form) + (or (special-operator-p symbol) + (macro-function symbol))) (global-boundp symbol-form) (and (boundp symbol) (not (constantp symbol)))))) @@ -1909,8 +1912,8 @@ (string-form (:options :face +italic-face+)) (comment (*retro-comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) - (complete-token-form (:function #'(lambda (syntax form) - (cond ((symbol-form-is-macrobound-p syntax form) + (complete-token-form (:function #'(lambda (view form) + (cond ((symbol-form-is-macrobound-p (syntax view) form) +bold-face-drawing-options+) (t +default-drawing-options+))))) (reader-conditional-positive-form

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by thenriksen 20 May '08

20 May '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv29122/Apps/Listener Modified Files: dev-commands.lisp Log Message: Listener now supports BREAKing of running evaluation by pressing the conveniently named Pause/Break key on the keyboard. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:12:09 1.56 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:16:02 1.57 @@ -1548,7 +1548,8 @@ #'(lambda () (throw 'done result)))))))) (handler-case (loop for gesture = (read-gesture) - when (event-matches-gesture-name-p gesture :pause) + when (and (typep gesture 'keyboard-event) + (eq (keyboard-event-key-name gesture) :pause)) do (clim-sys:process-interrupt eval-process #'break)) (abort-gesture () (clim-sys:destroy-process eval-process)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by thenriksen 20 May '08

20 May '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv28449/Apps/Listener Modified Files: dev-commands.lisp Log Message: Added better handling of abnormal exit when evaluating forms in the Listener. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 15:33:14 1.55 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:12:09 1.56 @@ -1519,36 +1519,53 @@ (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) - (flet ((evaluate () - (let ((- form)) - (multiple-value-list (eval form))))) - ;; If possible, use a thread for evaluation, permitting us to - ;; interrupt it. - (let* ((start-time (get-internal-real-time)) - (values + (let ((standard-output *standard-output*) + (standard-input *standard-input*)) + (flet ((evaluate () + (let ((- form) + (*standard-output* standard-output) + (*standard-input* standard-input) + error success) + (unwind-protect (handler-case (prog1 (cons :values (multiple-value-list (eval form))) + (setf success t)) + (condition (e) + (setf error e) + (error e))) + (when (and error (not success)) + (return-from evaluate (cons :error error))))))) + ;; If possible, use a thread for evaluation, permitting us to + ;; interrupt it. + (let ((start-time (get-internal-real-time))) + (destructuring-bind (result . value) (if clim-sys:*multiprocessing-p* (catch 'done (let* ((orig-process (clim-sys:current-process)) (eval-process (clim-sys:make-process #'(lambda () - (let ((values (evaluate))) + (let ((result (evaluate))) (clim-sys:process-interrupt orig-process #'(lambda () - (throw 'done values)))))))) - (handler-case (loop (read-gesture)) + (throw 'done result)))))))) + (handler-case (loop for gesture = (read-gesture) + when (event-matches-gesture-name-p gesture :pause) + do (clim-sys:process-interrupt eval-process #'break)) (abort-gesture () (clim-sys:destroy-process eval-process) - (with-text-style (t (make-text-style nil :italic nil)) - (format t "Aborted by user after ~F seconds." - (/ (- (get-internal-real-time) start-time) - internal-time-units-per-second))) - (return-from com-eval))))) - (evaluate)))) - (fresh-line) - (shuffle-specials form values) - (display-evalues values) - (fresh-line)))) + (cons :abort (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second)))))) + (evaluate)) + (ecase result + (:values + (fresh-line) + (shuffle-specials form value) + (display-evalues value) + (fresh-line)) + (:error (with-text-style (t (make-text-style nil :italic nil)) + (with-output-as-presentation (t value 'expression) + (format t "Aborted due to ~A: ~A" (type-of value) value)))) + (:abort (with-text-style (t (make-text-style nil :italic nil)) + (format t "Aborted by user after ~F seconds." value))))))))) ;;; Some CLIM developer commands

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by thenriksen 20 May '08

20 May '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13866/Apps/Listener Modified Files: dev-commands.lisp Log Message: Added the ability to cancel a computation in the CLIM Listener by pressing the abort gesture. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/04/14 16:55:05 1.54 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 15:33:14 1.55 @@ -1519,14 +1519,36 @@ (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) - (let* ((- form) - (values (multiple-value-list (eval form)))) - (fresh-line) - (shuffle-specials form values) - (display-evalues values) - (fresh-line))) - - + (flet ((evaluate () + (let ((- form)) + (multiple-value-list (eval form))))) + ;; If possible, use a thread for evaluation, permitting us to + ;; interrupt it. + (let* ((start-time (get-internal-real-time)) + (values + (if clim-sys:*multiprocessing-p* + (catch 'done + (let* ((orig-process (clim-sys:current-process)) + (eval-process + (clim-sys:make-process + #'(lambda () + (let ((values (evaluate))) + (clim-sys:process-interrupt orig-process + #'(lambda () + (throw 'done values)))))))) + (handler-case (loop (read-gesture)) + (abort-gesture () + (clim-sys:destroy-process eval-process) + (with-text-style (t (make-text-style nil :italic nil)) + (format t "Aborted by user after ~F seconds." + (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second))) + (return-from com-eval))))) + (evaluate)))) + (fresh-line) + (shuffle-specials form values) + (display-evalues values) + (fresh-line)))) ;;; Some CLIM developer commands

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 18 May '08

18 May '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv23401/ESA Modified Files: esa.lisp Log Message: Improve the ESA minibuffers handling of arbitrary output. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/17 21:25:35 1.24 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/18 09:24:06 1.25 @@ -160,9 +160,7 @@ (let* ((sr (call-next-method)) (height (max (text-style-height (medium-merged-text-style medium) medium) - (if (message pane) - (bounding-rectangle-height (message pane)) - 0)))) + (bounding-rectangle-height (stream-output-history pane))))) (make-space-requirement :height height :min-height height :max-height height :width (space-requirement-width sr)

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 18 May '08

18 May '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv21883/ESA Modified Files: esa-io.lisp Log Message: Move error ESA-IO handling into commands. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/05/18 09:09:22 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/05/18 09:20:21 1.11 @@ -136,7 +136,9 @@ If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." - (find-file filepath)) + (handler-case (find-file filepath) + (file-error (e) + (display-message "~A" e)))) (set-key `(com-find-file ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\f :control))) @@ -248,28 +250,25 @@ t))) (defmethod frame-save-buffer (application-frame buffer) - (handler-case - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (check-buffer-writability application-frame filepath buffer) - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from frame-save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil)) - (file-error (c) - (display-message "~A" c)))) + (let ((filepath (or (filepath buffer) + (accept 'pathname :prompt "Save Buffer to File")))) + (check-buffer-writability application-frame filepath buffer) + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from frame-save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) + (let ((backup-name (pathname-name filepath)) + (backup-type (format nil "~A~~~D~~" + (pathname-type filepath) + (1+ (version-number filepath))))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file. @@ -283,10 +282,8 @@ :default-type 'pathname)) (if (needs-saving buffer) (handler-case (save-buffer buffer) - (buffer-writing-error (e) - (with-minibuffer-stream (minibuffer) - (let ((*print-escape* nil)) - (print-object e minibuffer))))) + ((or buffer-writing-error file-error) (e) + (display-message "~A" e))) (display-message "No changes need to be saved from ~a" (name buffer)))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control)))

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 18 May '08

18 May '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv18592/ESA Modified Files: esa-io.lisp Log Message: Handle file-errors when writing files in ESA. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/29 22:59:30 1.9 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/05/18 09:09:22 1.10 @@ -248,25 +248,28 @@ t))) (defmethod frame-save-buffer (application-frame buffer) - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (check-buffer-writability application-frame filepath buffer) - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from frame-save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil))) + (handler-case + (let ((filepath (or (filepath buffer) + (accept 'pathname :prompt "Save Buffer to File")))) + (check-buffer-writability application-frame filepath buffer) + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from frame-save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) + (let ((backup-name (pathname-name filepath)) + (backup-type (format nil "~A~~~D~~" + (pathname-type filepath) + (1+ (version-number filepath))))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil)) + (file-error (c) + (display-message "~A" c)))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file.

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 17 May '08

17 May '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv7171/ESA Modified Files: esa.lisp Log Message: Improved the ESA minibuffer - can now resize itself if necessary and doesn't flicker. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/01 06:48:22 1.23 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/17 21:25:35 1.24 @@ -106,30 +106,45 @@ current message was set.")) (:default-initargs :scroll-bars nil - :display-function 'display-minibuffer - :display-time :no-clear - :incremental-redisplay t)) + :display-function 'display-minibuffer + :display-time :command-loop + :incremental-redisplay t)) + +(defmethod handle-repaint ((pane minibuffer-pane) region) + (when (and (message pane) + (> (get-universal-time) + (+ *minimum-message-time* (message-time pane)))) + (window-clear pane) + (setf (message pane) nil)) + (call-next-method)) + +(defmethod (setf message) :after (new-value (pane minibuffer-pane)) + (change-space-requirements pane)) + +(defmethod pane-needs-redisplay ((pane minibuffer-pane)) + ;; Always call the display function, never clear the window. This + ;; allows us to time-out the message in the minibuffer. + (values t nil)) -(defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) - (declare (ignore type args)) - (window-clear pane) - (when (message pane) - (setf (message pane) nil) - ;; FIXME: If we do not redisplay here, the area occupied by the - ;; message will be blanked with a white rectangle at the first - ;; keystroke. - (redisplay-frame-pane (pane-frame pane) pane))) +(defun display-minibuffer (frame pane) + (declare (ignore frame)) + (handle-repaint pane +everywhere+)) (defmethod stream-accept :around ((pane minibuffer-pane) type &rest args) (declare (ignore args)) + (when (message pane) + (setf (message pane) nil)) + (window-clear pane) ;; FIXME: this isn't the friendliest way of indicating a parse ;; error: there's no feedback, unlike emacs' quite nice "[no ;; match]". - (loop - (handler-case - (with-input-focus (pane) - (return (call-next-method))) - (parse-error () nil)))) + (unwind-protect + (loop + (handler-case + (with-input-focus (pane) + (return (call-next-method))) + (parse-error () nil))) + (window-clear pane))) (defmethod stream-accept ((pane minibuffer-pane) type &rest args &key (view (stream-default-view pane)) @@ -139,6 +154,21 @@ ;; but we need to turn some of ACCEPT-1 off. (apply #'accept-1-for-minibuffer pane type args)) +(defmethod compose-space ((pane minibuffer-pane) &key width height) + (declare (ignore width height)) + (with-sheet-medium (medium pane) + (let* ((sr (call-next-method)) + (height (max (text-style-height (medium-merged-text-style medium) + medium) + (if (message pane) + (bounding-rectangle-height (message pane)) + 0)))) + (make-space-requirement + :height height :min-height height :max-height height + :width (space-requirement-width sr) + :min-width (space-requirement-min-width sr) + :max-width (space-requirement-max-width sr))))) + ;;; simpler version of McCLIM's internal operators of the same names: ;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P ;;; and INVOKE-HANDLE-EMPTY-INPUT to support it. We don't support @@ -288,24 +318,15 @@ stream object object-type view :rescan nil)) (values object object-type))))) -(defun display-minibuffer (frame pane) - (declare (ignore frame)) - (if (message pane) - (if (> (get-universal-time) - (+ *minimum-message-time* (message-time pane))) - (setf (message pane) nil) - (replay-output-record (message pane) pane)) - ;; Even if there isn't a message, someone else might still have - ;; scribbled in the pane. We shouldn't disappoint them. - (replay (stream-output-history pane) pane))) - (defgeneric invoke-with-minibuffer-stream (minibuffer continuation)) (defmethod invoke-with-minibuffer-stream ((minibuffer minibuffer-pane) continuation) + (window-clear minibuffer) (setf (message minibuffer) - (with-output-to-output-record (minibuffer) + (with-new-output-record (minibuffer) (setf (message-time minibuffer) (get-universal-time)) - (funcall continuation minibuffer)))) + (filling-output (minibuffer :fill-width (bounding-rectangle-width minibuffer)) + (funcall continuation minibuffer))))) (defmethod invoke-with-minibuffer-stream ((minibuffer pointer-documentation-pane) continuation) (clim-extensions:with-output-to-pointer-documentation (stream (pane-frame minibuffer)) @@ -900,7 +921,7 @@ ;; for presentation-to-command-translators, ;; which are searched for in ;; (frame-command-table *application-frame*) - (redisplay-frame-pane ,frame (frame-standard-input ,frame) :force-p t) + (redisplay-frame-pane ,frame (frame-standard-input ,frame)) (setf (frame-command-table ,frame) command-table) (process-gestures-or-command ,frame)) (unbound-gesture-sequence (c)

1 0

[mcclim-cvs] CVS mcclim/Backends/beagle/windowing
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory clnet:/tmp/cvs-serv3307/Backends/beagle/windowing Modified Files: mirror.lisp port.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2006/03/29 10:43:38 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2008/05/16 14:05:27 1.8 @@ -235,8 +235,8 @@ (y 0) (width (space-requirement-width q)) (height (space-requirement-height q)) - (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) - (pixel-count width) (pixel-count height))) + (rect (make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (name (%make-nsstring (frame-pretty-name frame))) (top-level-frame (%beagle-make-window (beagle-port-screen port) rect @@ -266,8 +266,8 @@ (y 0) (width (space-requirement-width q)) (height (space-requirement-height q)) - (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) - (pixel-count width) (pixel-count height))) + (rect (make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (menu-frame (%beagle-make-window (beagle-port-screen port) rect :decorated nil)) (clim-mirror (make-instance 'lisp-view :with-frame rect))) (send clim-mirror 'retain) @@ -294,8 +294,8 @@ (q (compose-space sheet)) (width (space-requirement-width q)) (height (space-requirement-height q)) - (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) - (pixel-count width) (pixel-count height))) + (rect (make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (mirror (make-instance view :with-frame rect))) (#_free rect) (send mirror 'retain) @@ -331,8 +331,8 @@ (defmethod realize-mirror ((port beagle-port) (pixmap pixmap)) (when (null (port-lookup-mirror port pixmap)) - (let* ((width (coerce (pixmap-width pixmap) 'short-float)) - (height (coerce (pixmap-height pixmap) 'short-float)) + (let* ((width (cg-floatify (pixmap-width pixmap))) + (height (cg-floatify (pixmap-height pixmap))) (mirror (make-instance 'lisp-image))) ;; :with-frame rect))) (send mirror 'retain) (slet ((size (ccl::ns-make-size width height))) @@ -432,9 +432,8 @@ ;; We've handled the frame (if necessary) - now resize the mirror itself. (slet ((frame-size (send mirror 'frame))) - (rlet ((size :<NSS>ize :width (coerce (floor (bounding-rectangle-width mirror-region)) - 'short-float) - :height (coerce (floor (bounding-rectangle-height mirror-region)) 'short-float))) + (rlet ((size :<NSS>ize :width (cg-floatify (floor (bounding-rectangle-width mirror-region))) + :height (cg-floatify (floor (bounding-rectangle-height mirror-region))))) ;; ignore this (for now) #+nil (when (and (equal (pref frame-size :<NSR>ect.size.width) (pref size :<NSS>ize.width)) @@ -448,9 +447,8 @@ (slet ((frame-rect (send mirror 'frame))) (rlet ((rect :<NSR>ect :origin.x (pref frame-rect :<NSR>ect.origin.x) :origin.y (pref frame-rect :<NSR>ect.origin.y) - :size.width (coerce (floor (bounding-rectangle-width mirror-region)) 'short-float) - :size.height (coerce (floor (bounding-rectangle-height mirror-region)) - 'short-float))) + :size.width (cg-floatify (floor (bounding-rectangle-width mirror-region))) + :size.height (cg-floatify (floor (bounding-rectangle-height mirror-region))))) (send (send mirror 'window) :set-frame (send (send mirror 'window) :frame-rect-for-content-rect rect @@ -547,7 +545,7 @@ (let* ((app-tls (frame-top-level-sheet (pane-frame sheet))) (tls-mirror (port-lookup-mirror port app-tls)) (tls-window (send tls-mirror 'window)) - (origin-pt (ccl::make-ns-point 0.0 0.0))) + (origin-pt (make-ns-point 0.0 0.0))) (slet ((frame-pt (send tls-window :convert-base-to-screen origin-pt)) (tls-bounds (send tls-mirror 'bounds))) (#_free origin-pt) @@ -560,8 +558,7 @@ ;;; (setf y (+ y frame-y)) (setf y (- (+ frame-y tls-height) y))))))) - (let ((point (ccl::make-ns-point (coerce x 'short-float) - (coerce y 'short-float)))) + (let ((point (make-ns-point x y))) (send (send mirror 'window) :set-frame-top-left-point point) (#_free point))))) @@ -606,11 +603,9 @@ (%beagle-port-move-mirror-window port mirror mirror-transformation) (slet ((mirror-bounds (send mirror 'bounds)) (frame-origin (send mirror 'frame))) ;position + size _in parent_ - (let* ((x (coerce (floor (nth-value 0 (transform-position mirror-transformation 0 0))) - 'short-float)) - (y (coerce (floor (nth-value 1 (transform-position mirror-transformation 0 0))) - 'short-float)) - (point (ccl::make-ns-point x y))) + (let* ((x (floor (nth-value 0 (transform-position mirror-transformation 0 0)))) + (y (floor (nth-value 1 (transform-position mirror-transformation 0 0)))) + (point (make-ns-point x y))) ;; Skip this (for now...) #+nil (when (and (equal (pref frame-origin :<NSR>ect.origin.x) x) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2007/12/18 10:54:22 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2008/05/16 14:05:28 1.8 @@ -164,16 +164,16 @@ ;;; From CLX/port.lisp -(defun %beagle-pixel (port color &key (alpha 1.0)) +(defun %beagle-pixel (port color &key (alpha #.(cg-floatify 1.0))) (let* ((table (slot-value port 'color-table)) (nscol (gethash color table))) (when (null nscol) (setf (gethash color table) (multiple-value-bind (r g b) (color-rgb color) - (let ((nsc (send (@class ns-color) :color-with-calibrated-red (coerce r 'short-float) - :green (coerce g 'short-float) - :blue (coerce b 'short-float) - :alpha (coerce alpha 'short-float)))) + (let ((nsc (send (@class ns-color) :color-with-calibrated-red (cg-floatify r) + :green (cg-floatify g) + :blue (cg-floatify b) + :alpha (cg-floatify alpha)))) (send nsc 'retain))))) (gethash color table)))

1 0

[mcclim-cvs] CVS mcclim/Backends/beagle/output
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory clnet:/tmp/cvs-serv3307/Backends/beagle/output Modified Files: fonts.lisp medium.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2007/12/18 10:54:22 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2008/05/16 14:05:23 1.5 @@ -37,13 +37,13 @@ :serif "Times New Roman" :sans-serif "Verdana")) -(defparameter *beagle-text-sizes* '(:normal 12.0 - :tiny 9.0 - :very-small 10.0 - :small 11.0 - :large 14.0 - :very-large 18.0 - :huge 24.0)) +(defparameter *beagle-text-sizes* '(:normal #.(cg-floatify 12.0) + :tiny #.(cg-floatify 9.0) + :very-small #.(cg-floatify 10.0) + :small #.(cg-floatify 11.0) + :large #.(cg-floatify 14.0) + :very-large #.(cg-floatify 18.0) + :huge #.(cg-floatify 24.0))) (defparameter *beagle-native-fonts* (make-hash-table :test #'equal)) (defparameter *beagle-font-metrics* (make-hash-table :test #'equal)) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2006/03/29 10:43:38 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2008/05/16 14:05:23 1.6 @@ -84,7 +84,7 @@ (defmethod (setf medium-line-style) :before (line-style (medium beagle-medium)) (unless (equal (medium-line-style medium) line-style) - (let ((width (coerce (line-style-thickness line-style) 'short-float)) + (let ((width (cg-floatify (line-style-thickness line-style))) (cap (%translate-cap-shape (line-style-cap-shape line-style))) (dashes (line-style-dashes line-style)) (join (%translate-joint-shape (line-style-joint-shape line-style)))) @@ -344,7 +344,7 @@ (defmethod %clim-opacity-from-design ((medium beagle-medium) design) (declare (ignore medium design)) ;; Just a stub for now. ::FIXME:: Need to ask on the list about this... - 1.0) + #.(cg-floatify 1.0)) (defmethod %clim-colour-from-design ((medium beagle-medium) (design climi::indirect-ink)) @@ -477,12 +477,8 @@ (defun medium-copy-area-aux (from from-x from-y width height to to-x to-y) "Helper method for copying areas. 'from' and 'to' must both be 'mirror' objects. From and To coordinates must already be transformed as appropriate." - (let* ((source-region (ccl::make-ns-rect (coerce from-x 'short-float) - (coerce from-y 'short-float) - (coerce width 'short-float) - (coerce height 'short-float))) - (target-point (ccl::make-ns-point (coerce to-x 'short-float) - (coerce to-y 'short-float))) + (let* ((source-region (make-ns-rect from-x from-y width height)) + (target-point (make-ns-point to-x to-y)) (bitmap-image (send from :copy-bitmap-from-region source-region))) (when (eql bitmap-image (%null-ptr)) (warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%") @@ -581,10 +577,10 @@ (do-sequence ((left top right bottom) coord-seq) (when (< right left) (rotatef left right)) (when (< top bottom) (rotatef top bottom)) - (let ((rect (ccl::make-ns-rect (pixel-center left) - (pixel-center bottom) - (pixel-count (- right left)) - (pixel-count (- top bottom))))) + (let ((rect (make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) (send path :append-bezier-path-with-rect rect) (#_free rect))) (if filled @@ -594,16 +590,15 @@ ;; ::FIXME:: Move these from here! (defun pixel-center (pt) "Ensure any ordinate provided sits on the center of a pixel. This -prevents Cocoa from 'antialiasing' lines, making them thicker and -a shade of grey. Ensures the return value is a short-float, as -required by the Cocoa methods." - (coerce (+ (round-coordinate pt) 0.5) 'short-float)) +prevents Cocoa from 'antialiasing' lines, making them thicker and a +shade of grey. Ensures the return value is an appropriate float type." + (cg-floatify (+ (round-coordinate pt) 0.5))) (defun pixel-count (sz) "Ensures any value provided is rounded to the nearest unit, and -returned as a short-float as required by the Cocoa methods." - (coerce (round-coordinate sz) 'short-float)) +returned as an appropriate float type." + (cg-floatify (round-coordinate sz))) ;;; Nabbed from CLX backend medium.lisp @@ -657,10 +652,10 @@ (origin-y (- center-y radius-dy)) (width (* 2 radius-dx)) (height (* 2 radius-dy)) - (rect (ccl::make-ns-rect (pixel-center origin-x) - (pixel-center origin-y) - (pixel-count width) - (pixel-count height)))) + (rect (make-ns-rect (pixel-center origin-x) + (pixel-center origin-y) + (pixel-count width) + (pixel-count height)))) (send path :append-bezier-path-with-oval-in-rect rect) (#_free rect) (if filled @@ -677,8 +672,8 @@ (pixel-center center-y)))) (send path :append-bezier-path-with-arc-with-center point :radius (pixel-count radius) - :start-angle (coerce (/ start-angle (/ pi 180)) 'short-float) - :end-angle (coerce (/ end-angle (/ pi 180)) 'short-float) + :start-angle (cg-floatify (/ start-angle (/ pi 180))) + :end-angle (cg-floatify (/ end-angle (/ pi 180))) :clockwise NIL))) (if filled (send mirror :fill-path path :in-colour colour) @@ -692,8 +687,7 @@ ;;; Draws a point on the medium 'medium'. (defmethod medium-draw-point* ((medium beagle-medium) x y) - (let ((width (coerce (line-style-thickness (medium-line-style medium)) - 'short-float))) + (let ((width (cg-floatify (line-style-thickness (medium-line-style medium))))) (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))) @@ -707,7 +701,7 @@ (defmethod medium-draw-points* ((medium beagle-medium) coord-seq) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) - (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) + (let ((width (cg-floatify (line-style-thickness (medium-line-style medium))))) (do-sequence ((x y) coord-seq) (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))))) @@ -775,10 +769,10 @@ (send mirror :draw-image colour :at-point (ns-make-point (pixel-center left) (pixel-center top))) (return-from medium-draw-rectangle* (values))) - (let ((rect (ccl::make-ns-rect (pixel-center left) - (pixel-center bottom) - (pixel-count (- right left)) - (pixel-count (- top bottom))))) + (let ((rect (make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) (send path :append-bezier-path-with-rect rect) (#_free rect) (if filled @@ -853,8 +847,7 @@ (:baseline (- y baseline)) ;;; (:bottom y))) (:bottom (- y text-height)))) - (slet ((point (ns-make-point (coerce x 'short-float) - (coerce y 'short-float)))) + (slet ((point (ns-make-point (cg-floatify x) (cg-floatify y)))) (let ((objc-string (%make-nsstring (subseq string start end)))) ;; NB: draw-string-at-point uses upper-left as origin in a flipped ;; view.

1 0

← Newer
1
...
8
9
10
11
12
13
14
...
170
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs