May 2008 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim/Lisp-Dep
by thenriksen 29 May '08

29 May '08

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv11374/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: SBCL multiprocessing patch from Christophe that allows saved cores to work. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:45 1.13 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:12:03 1.14 @@ -42,16 +42,24 @@ function thread) -(defvar *current-process* +(defun make-current-process () (%make-process :name (sb-thread:thread-name sb-thread:*current-thread*) :function nil :thread sb-thread:*current-thread*)) +(defvar *current-process* (make-current-process)) + (defvar *all-processes* (list *current-process*) "A list of processes created by McCLIM, plus the one that was running when this file was loaded.") +(defun reinit-processes () + (setf *current-process* (make-current-process)) + (setf *all-processes* (list *current-process*))) + +(push 'reinit-processes sb-ext:*init-hooks*) + (defvar *all-processes-lock* (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*"))

1 0

[mcclim-cvs] CVS mcclim/Lisp-Dep
by thenriksen 29 May '08

29 May '08

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv11272/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: Move *all-processes* handling into the function passed to SB-THREAD:MAKE-THREAD. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:28 1.12 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:45 1.13 @@ -48,7 +48,9 @@ :function nil :thread sb-thread:*current-thread*)) -(defvar *all-processes* (list *current-process*)) +(defvar *all-processes* (list *current-process*) + "A list of processes created by McCLIM, plus the one that was +running when this file was loaded.") (defvar *all-processes-lock* (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) @@ -64,21 +66,21 @@ (defun make-process (function &key name) (let ((p (%make-process :name name :function function))) - (sb-thread:with-mutex (*all-processes-lock*) - (pushnew p *all-processes*)) (restart-process p))) (defun restart-process (p) (labels ((boing () (let ((*current-process* p)) - (funcall (process-function p) )))) + (sb-thread:with-mutex (*all-processes-lock*) + (pushnew p *all-processes*)) + (unwind-protect (funcall (process-function p)) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete p *all-processes*))))))) (when (process-thread p) (sb-thread:terminate-thread p)) (when (setf (process-thread p) (sb-thread:make-thread #'boing :name (process-name p))) p))) (defun destroy-process (process) - (sb-thread:with-mutex (*all-processes-lock*) - (setf *all-processes* (delete process *all-processes*))) (sb-thread:terminate-thread (process-thread process))) (defun current-process () @@ -87,6 +89,8 @@ (setf *current-process* (or (find sb-thread:*current-thread* *all-processes* :key #'process-thread) + ;; Don't add this to *all-processes*, because we don't + ;; control it. (%make-process :name (sb-thread:thread-name sb-thread:*current-thread*) :function nil

1 0

[mcclim-cvs] CVS mcclim/Lisp-Dep
by thenriksen 29 May '08

29 May '08

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv11208/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: Improved CLIM-SYS:CURRENT-PROCESS on SBCL. Should now always return the correct process, even within processes not started by McCLIM. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2007/12/16 23:20:11 1.11 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:28 1.12 @@ -44,12 +44,9 @@ (defvar *current-process* (%make-process - :name "initial process" :function nil - :thread - #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - sb-thread:*current-thread* - #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - (sb-thread:current-thread-id))) + :name (sb-thread:thread-name sb-thread:*current-thread*) + :function nil + :thread sb-thread:*current-thread*)) (defvar *all-processes* (list *current-process*)) @@ -85,7 +82,15 @@ (sb-thread:terminate-thread (process-thread process))) (defun current-process () - *current-process*) + (if (eq (process-thread *current-process*) sb-thread:*current-thread*) + *current-process* + (setf *current-process* + (or (find sb-thread:*current-thread* *all-processes* + :key #'process-thread) + (%make-process + :name (sb-thread:thread-name sb-thread:*current-thread*) + :function nil + :thread sb-thread:*current-thread*))))) (defun all-processes () ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value

1 0

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

27 May '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv26543/Apps/Listener Modified Files: dev-commands.lisp Log Message: Handle BREAK in the Listener. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:53:55 1.59 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 16:00:58 1.60 @@ -1532,7 +1532,7 @@ (serious-condition (e) (setf error e) (error e))) - (when (and error (not success)) + (when (not success) (return-from evaluate (cons :error error))))))) ;; If possible, use a thread for evaluation, permitting us to ;; interrupt it. @@ -1568,8 +1568,10 @@ (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)))) + (if value + (with-output-as-presentation (t value 'expression) + (format t "Aborted due to ~A: ~A" (type-of value) value)) + (format t "Aborted for unknown reasons (possibly use of ~A)." 'break)))) (:abort (with-text-style (t (make-text-style nil :italic nil)) (format t "Aborted by user after ~F seconds." value)))))))))

1 0

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

27 May '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv25296/Apps/Listener Modified Files: dev-commands.lisp Log Message: As per the advice of Nikodemus, only handle serious-condition in the Listener. Also rebind *error-output*. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:30:32 1.58 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:53:55 1.59 @@ -1525,10 +1525,11 @@ (let ((- form) (*standard-output* standard-output) (*standard-input* standard-input) + (*error-output* standard-output) error success) (unwind-protect (handler-case (prog1 (cons :values (multiple-value-list (eval form))) (setf success t)) - (condition (e) + (serious-condition (e) (setf error e) (error e))) (when (and error (not success))

1 0

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

27 May '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv21697/Apps/Listener Modified Files: dev-commands.lisp Log Message: In the Listener, handle abort gesture properly even if the eval-thread is in the debugger. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:16:02 1.57 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:30:32 1.58 @@ -1540,21 +1540,25 @@ (if clim-sys:*multiprocessing-p* (catch 'done (let* ((orig-process (clim-sys:current-process)) + (evaluating t) (eval-process (clim-sys:make-process #'(lambda () (let ((result (evaluate))) - (clim-sys:process-interrupt orig-process - #'(lambda () - (throw 'done result)))))))) - (handler-case (loop for gesture = (read-gesture) - 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) - (cons :abort (/ (- (get-internal-real-time) start-time) - internal-time-units-per-second)))))) + (when evaluating + (clim-sys:process-interrupt orig-process + #'(lambda () + (throw 'done result))))))))) + (unwind-protect + (handler-case (loop for gesture = (read-gesture) + 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) + (cons :abort (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second)))) + (setf evaluating nil)))) (evaluate)) (ecase result (:values

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 27 May '08

27 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3639 Modified Files: presentation-defs.lisp Log Message: Change over-eager call to DIRECTORY for pathname completion... should now use the entered input to create the wild pathname. Assumes Unix-style wild pathnames, but the whole pathname completion thing is Unix-specific anyway, so... --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 09:26:49 1.77 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/05/27 13:15:36 1.78 @@ -1614,72 +1614,76 @@ 'pathname) (defun filename-completer (so-far mode) - (flet ((remove-trail (s) - (subseq s 0 (let ((pos (position #\/ s :from-end t))) - (if pos (1+ pos) 0))))) - (let* ((directory-prefix - (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) - "" - (namestring #+sbcl *default-pathname-defaults* - #+cmu (ext:default-directory) - #-(or sbcl cmu) *default-pathname-defaults*))) - (full-so-far (concatenate 'string directory-prefix so-far)) - (pathnames - (loop with length = (length full-so-far) - and wildcard = (concatenate 'string (remove-trail so-far) "*.*") - for path in - #+(or sbcl cmu lispworks) (directory wildcard) - #+openmcl (directory wildcard :directories t) - #+allegro (directory wildcard :directories-are-files nil) - #+cormanlisp (nconc (directory wildcard) - (cl::directory-subdirs dirname)) - #-(or sbcl cmu lispworks openmcl allegro cormanlisp) - (directory wildcard) - when (let ((mismatch (mismatch (namestring path) full-so-far))) - (or (null mismatch) (= mismatch length))) - collect path)) - (strings (mapcar #'namestring pathnames)) - (first-string (car strings)) - (length-common-prefix nil) - (completed-string nil) - (full-completed-string nil) - (input-is-directory-p (when (plusp (length so-far)) - (char= (aref so-far (1- (length so-far))) #\/)))) - (unless (null pathnames) - (setf length-common-prefix - (loop with length = (length first-string) - for string in (cdr strings) - do (setf length (min length (or (mismatch string first-string) length))) - finally (return length)))) - (unless (null pathnames) - (setf completed-string - (subseq first-string (length directory-prefix) - (if (null (cdr pathnames)) nil length-common-prefix))) - (setf full-completed-string - (concatenate 'string directory-prefix completed-string))) - (case mode - ((:complete-limited :complete-maximal) - (cond ((null pathnames) - (values so-far nil nil 0 nil)) - ((null (cdr pathnames)) - (values completed-string (plusp (length so-far)) (car pathnames) 1 nil)) - (input-is-directory-p - (values completed-string t (parse-namestring so-far) (length pathnames) nil)) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:complete - ;; This is reached when input is activated, if we did - ;; completion, that would mean that an input of "foo" would - ;; be expanded to "foobar" if "foobar" exists, even if the - ;; user actually *wants* the "foo" pathname (to create the - ;; file, for example). - (values so-far t so-far 1 nil)) - (:possibilities - (values nil nil nil (length pathnames) - (loop with length = (length directory-prefix) - for name in pathnames - collect (list (subseq (namestring name) length nil) - name)))))))) + (let* ((directory-prefix + (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) + "" + (namestring #+sbcl *default-pathname-defaults* + #+cmu (ext:default-directory) + #-(or sbcl cmu) *default-pathname-defaults*))) + (full-so-far (concatenate 'string directory-prefix so-far)) + (pathnames + (loop with length = (length full-so-far) + and wildcard = (format nil "~A*.*" + (loop for start = 0 ; Replace * -> \* + for occurence = (position #\* so-far :start start) + until (= start (length so-far)) + until (null occurence) + do (replace so-far "\\*" :start1 occurence) + (setf start (+ occurence 2)) + finally (return so-far))) + for path in + #+(or sbcl cmu lispworks) (directory wildcard) + #+openmcl (directory wildcard :directories t) + #+allegro (directory wildcard :directories-are-files nil) + #+cormanlisp (nconc (directory wildcard) + (cl::directory-subdirs dirname)) + #-(or sbcl cmu lispworks openmcl allegro cormanlisp) + (directory wildcard) + when (let ((mismatch (mismatch (namestring path) full-so-far))) + (or (null mismatch) (= mismatch length))) + collect path)) + (strings (mapcar #'namestring pathnames)) + (first-string (car strings)) + (length-common-prefix nil) + (completed-string nil) + (full-completed-string nil) + (input-is-directory-p (when (plusp (length so-far)) + (char= (aref so-far (1- (length so-far))) #\/)))) + (unless (null pathnames) + (setf length-common-prefix + (loop with length = (length first-string) + for string in (cdr strings) + do (setf length (min length (or (mismatch string first-string) length))) + finally (return length)))) + (unless (null pathnames) + (setf completed-string + (subseq first-string (length directory-prefix) + (if (null (cdr pathnames)) nil length-common-prefix))) + (setf full-completed-string + (concatenate 'string directory-prefix completed-string))) + (case mode + ((:complete-limited :complete-maximal) + (cond ((null pathnames) + (values so-far nil nil 0 nil)) + ((null (cdr pathnames)) + (values completed-string (plusp (length so-far)) (car pathnames) 1 nil)) + (input-is-directory-p + (values completed-string t (parse-namestring so-far) (length pathnames) nil)) + (t + (values completed-string nil nil (length pathnames) nil)))) + (:complete + ;; This is reached when input is activated, if we did + ;; completion, that would mean that an input of "foo" would + ;; be expanded to "foobar" if "foobar" exists, even if the + ;; user actually *wants* the "foo" pathname (to create the + ;; file, for example). + (values so-far t so-far 1 nil)) + (:possibilities + (values nil nil nil (length pathnames) + (loop with length = (length directory-prefix) + for name in pathnames + collect (list (subseq (namestring name) length nil) + name))))))) (define-presentation-method accept ((type pathname) stream (view textual-view) &key (default *default-pathname-defaults* defaultp)

1 0

[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-serv10700/Drei Modified Files: input-editor.lisp Log Message: Rebind *original-stream* when unreading gesture to prevent annoying bugs. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/04/30 21:27:46 1.47 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/05/24 12:00:29 1.48 @@ -634,7 +634,8 @@ (rescan-if-necessary stream) (return-from stream-process-gesture gesture)) (when (proper-gesture-p gesture) - (unread-gesture gesture :stream (encapsulating-stream-stream stream))) + (let ((*original-stream* (encapsulating-stream-stream stream))) + (unread-gesture gesture :stream (encapsulating-stream-stream stream)))) (read-gestures-and-act stream gesture type)) (defmethod reset-scan-pointer ((stream drei-input-editing-mixin)

1 0

[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-serv10040/Drei Modified Files: search-commands.lisp Log Message: Fix some old code that assumed Drei instances themselves contain points. --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/04/28 20:48:55 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/05/24 11:57:12 1.11 @@ -32,16 +32,16 @@ (defun simple-search (drei-instance search-function targets more-targets-predicate more-targets-fn) - (let ((old-buffer (buffer drei-instance)) - (old-offset (offset (point drei-instance)))) + (let ((old-buffer (buffer (view drei-instance))) + (old-offset (offset (point (view drei-instance))))) (activate-target-specification targets) - (or (loop until (funcall search-function (point drei-instance)) + (or (loop until (funcall search-function (point (view drei-instance))) if (funcall more-targets-predicate targets) do (funcall more-targets-fn targets) else return nil finally (return t)) - (setf (buffer drei-instance) old-buffer - (offset (point drei-instance)) old-offset)))) + (setf (buffer (view drei-instance)) old-buffer + (offset (point (view drei-instance))) old-offset)))) (defun simple-search-forward (drei-instance search-function &optional (targets (funcall *default-target-creator* drei-instance))) @@ -244,7 +244,7 @@ until (search-success-p (first (isearch-states (drei-instance)))) do (pop (isearch-states (drei-instance)))) (let ((state (first (isearch-states (drei-instance))))) - (setf (offset (point (drei-instance))) + (setf (offset (point (view (drei-instance)))) (if (search-forward-p state) (+ (offset (search-mark state)) (length (search-string state)))

1 0

[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

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

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes In directory clnet:/tmp/cvs-serv3307/Backends/beagle/native-panes Modified Files: beagle-fundamental-button-pane.lisp beagle-scroll-bar-pane.lisp beagle-slider-pane.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/native-panes/beagle-fundamental-button-pane.lisp 2005/06/12 16:53:26 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-fundamental-button-pane.lisp 2008/05/16 14:05:15 1.2 @@ -77,10 +77,11 @@ (defun %beagle-get-label-size (label sheet) - (let ((retsize 0.0) + (let ((retsize (cg-floatify 0.0)) (dictionary (reuse-attribute-dictionary (sheet-medium sheet) (send (@class ns-font) - :system-font-of-size 0.0)))) + :system-font-of-size + (cg-floatify 0.0))))) (slet ((label-size (send (ccl::%make-nsstring label) :size-with-attributes dictionary))) (setf retsize label-size) @@ -100,12 +101,13 @@ (defmethod compose-space ((pb beagle-push-button-pane) &key width height) (declare (ignore width height)) ;; - magic numbers are from the HIG - (let ((column-spacing 12.0) - (row-spacing 12.0) - (standard-width-sans-ends 41.0) - (standard-end-size 28.0) - (standard-width 69.0) ; width of OK, Cancel buttons - (standard-height 20.0) + (let ((column-spacing #.(cg-floatify 12.0)) + (row-spacing #.(cg-floatify 12.0)) + (standard-width-sans-ends #.(cg-floatify 41.0)) + (standard-end-size #.(cg-floatify 28.0)) + ; width of OK, Cancel buttons + (standard-width #.(cg-floatify 69.0)) + (standard-height #.(cg-floatify 20.0)) (label-size (%beagle-get-label-size (gadget-label pb) pb))) (let ((width (if (< (pref label-size :<NSS>ize.width) standard-width-sans-ends) standard-width-sans-ends @@ -125,10 +127,10 @@ (sheet beagle-push-button-pane)) (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (coerce (space-requirement-width q) 'short-float) - (coerce (space-requirement-height q) 'short-float))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-button :with-frame rect))) (send mirror 'retain) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/04/25 18:50:31 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2008/05/16 14:05:17 1.10 @@ -21,10 +21,10 @@ ;; bar; otherwise we get a :vertical bar. (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (space-requirement-width q) - (space-requirement-height q))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-scroller :with-frame rect))) (send mirror 'retain) @@ -33,7 +33,7 @@ (send mirror :set-enabled #$YES) ;; Make knob fill pane initially. - (send mirror :set-float-value 0.0 :knob-proportion 1.0) + (send mirror :set-float-value 0.0 :knob-proportion #.(cg-floatify 1.0)) (setf (toolkit-object sheet) mirror) (setf (view-lisp-scroller mirror) sheet) @@ -99,7 +99,7 @@ (/ ts (+ range ts))))) (send (toolkit-object scroll-bar) :set-float-value (coerce (clamp value 0.0 1.0) 'short-float) - :knob-proportion (coerce (clamp loz-size 0.0 1.0) 'short-float)))) + :knob-proportion (cg-floatify (clamp loz-size 0.0 1.0))))) (defmethod (setf gadget-min-value) :after (new-value (pane beagle-scroll-bar-pane)) @@ -153,7 +153,7 @@ (/ size range)))) (send (toolkit-object gadget) :set-float-value (coerce position 'short-float) - :knob-proportion (coerce loz-size 'short-float))))) + :knob-proportion (cg-floatify loz-size))))) ;;; Called in the Cocoa App thread. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-slider-pane.lisp 2005/06/12 13:27:42 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-slider-pane.lisp 2008/05/16 14:05:18 1.2 @@ -26,10 +26,10 @@ ;; bar; otherwise we get a :vertical bar. (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (coerce (space-requirement-width q) 'short-float) - (coerce (space-requirement-height q) 'short-float))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-slider :with-frame rect))) (send mirror 'retain)

1 0

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

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory clnet:/tmp/cvs-serv3307/Backends/beagle/native Modified Files: lisp-bezier-path.lisp lisp-image.lisp lisp-view.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/native/lisp-bezier-path.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-bezier-path.lisp 2008/05/16 14:05:11 1.2 @@ -28,7 +28,7 @@ (defclass lisp-bezier-path (ns:ns-bezier-path) ((colour :foreign-type :id :accessor path-colour) - (fill :foreign-type :bool + (fill :foreign-type :<bool> :initform #$NO :accessor path-fill)) (:metaclass ns:+ns-object)) @@ -36,7 +36,7 @@ (define-objc-method ((:void :set-colour colour) lisp-bezier-path) (setf (path-colour self) colour)) -(define-objc-method ((:void :set-fill (:bool fill)) lisp-bezier-path) +(define-objc-method ((:void :set-fill (:<bool> fill)) lisp-bezier-path) (setf (path-fill self) fill)) (define-objc-method ((:void draw) lisp-bezier-path) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-image.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-image.lisp 2008/05/16 14:05:11 1.2 @@ -129,7 +129,7 @@ (progn (send self 'lock-focus) (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0))) ;;; (send (send self 'window) 'flush-window) (send self 'unlock-focus)))) ;;; (format *debug-io* "(paste-bitmap...) - FAILED TO LOCK FOCUS ON VIEW (NOT VALID) ~S!!!~%" self))) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2006/03/24 11:18:27 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2008/05/16 14:05:11 1.3 @@ -119,7 +119,7 @@ (when (send self 'lock-focus-if-can-draw) (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0))) ;;; (send (send self 'window) 'flush-window) (send self 'unlock-focus)) ;;; (send (send self 'window) 'flush-window)) @@ -127,7 +127,7 @@ (define-objc-method ((:void :draw-image image :at-point (:<NSP>oint point)) lisp-view) (when (send self 'lock-focus-if-can-draw) - (send image :dissolve-to-point point :fraction 1.0) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0)) (send self 'unlock-focus))) ;;; ----------------------------------------------------------------------------

1 0

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

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory clnet:/tmp/cvs-serv3307/Backends/beagle Modified Files: cocoa-util.lisp package.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/cocoa-util.lisp 2005/06/05 19:52:54 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/cocoa-util.lisp 2008/05/16 14:05:09 1.5 @@ -23,30 +23,33 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :ccl) +(in-package :beagle) + +(declaim (inline cg-floatify)) +(defun cg-floatify (cg-float-value) + (float cg-float-value ns:+cgfloat-zero+)) -;; Make an NSRect structure with the origin at (x, y) and with the width and height -;; specified. (defun make-ns-rect (x y width height) "Make a Cocoa NSRect structure with the origin at (x, y) and with the width and height specified. The memory for any structure created with this method must be released by the user (using (#_free))." - (make-record :<NSR>ect :origin.x x - :origin.y y - :size.width width - :size.height height)) + (ccl:make-record :<NSR>ect + :origin.x (cg-floatify x) + :origin.y (cg-floatify y) + :size.width (cg-floatify width) + :size.height (cg-floatify height))) (defun make-ns-point (x y) "Make a Cocoa NSPoint structure populated with x and y provided. The memory for any structure created with this method must be released by the user (using (#_free))." - (make-record :<NSP>oint :x x :y y)) + (ccl:make-record :<NSP>oint :x (cg-floatify x) :y (cg-floatify y))) ;; Stolen from Bosco "main.lisp". (defun description (c) - (with-autorelease-pool - (lisp-string-from-nsstring - (send c 'description)))) + (ccl::with-autorelease-pool + (ccl::lisp-string-from-nsstring + (ccl::send c 'description)))) (defun nslog (c) (let* ((rep (format nil "~a" c))) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2007/12/18 10:54:21 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2008/05/16 14:05:09 1.7 @@ -1,18 +1,5 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :cocoa)) - -;;; START - Cribbed from framework/cocoa-support.lisp -(in-package "CCL") -(defun nslog (c) - "Writes a string message to the OSX console log." - (let* ((rep (format nil "~a" c))) - (with-cstrs ((str rep)) - (with-nsstr (nsstr str (length rep)) - (#_NSLog #@"Logging: %@" :address nsstr))))) -;;; END - (in-package :common-lisp-user) (defpackage :beagle @@ -84,11 +71,9 @@ (:import-from :ccl #:@class #:define-objc-method - #:description #:get-selector-for #:make-cstring #:%make-nsstring - #:nslog #:ns-make-point #:%null-ptr #:pref

1 0

[mcclim-cvs] CVS mcclim
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3307 Modified Files: mcclim.asd 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/mcclim.asd 2008/05/01 21:45:23 1.83 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/16 14:05:07 1.84 @@ -82,11 +82,9 @@ (defsystem :clx :class requireable-system)) -;;; Required for the beagle backend (not activated by default) +;;; Clozure CL native GUI stuff #+clim-beagle -(progn - (require :cocoa) - (require :objc-support)) +(require :cocoa) (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn @@ -405,6 +403,7 @@ :serial t :components ((:file "package") + (:file "cocoa-util") (:module "native" :components ((:file "lisp-bezier-path") (:file "lisp-window") @@ -417,7 +416,6 @@ (:file "lisp-slider") (:file "lisp-button") (:file "lisp-image"))) - (:file "cocoa-util") (:module "windowing" :depends-on ("native") :components ((:file "port")

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 15 May '08

15 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7688 Modified Files: text-formatting.lisp Log Message: FILLING-OUTPUT fixes: * Very naive and inefficient implementation of STREAM-WRITE-STRING. * Silenced compiler warning. --- /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2006/03/29 10:43:37 1.9 +++ /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2008/05/15 16:07:59 1.10 @@ -80,13 +80,17 @@ (encapsulating-stream-stream stream)))) (call-next-method)))) +(defmethod stream-write-string :around ((stream filling-stream) string + &optional (start 0) (end (length string))) + (dotimes (i (- end start)) + (stream-write-char stream (aref string (+ i start))))) + ;;; All the monkey business with the lambda form has to do with capturing the ;;; keyword arguments of the macro while preserving the user's evaluation order. (defmacro filling-output ((stream &rest args &key fill-width break-characters after-line-break after-line-break-initially) &body body) - (declare (ignore after-line-break-initially)) (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (fill-var break-var after-var initially-var) @@ -94,7 +98,7 @@ ((:break-characters ,break-var)) ((:after-line-break ,after-var)) ((:after-line-break-initially ,initially-var))) - (declare (ignorable ,fill-var ,break-var ,after-var)) + (declare (ignorable ,fill-var ,break-var ,after-var ,initially-var)) (let ((,stream (make-instance 'filling-stream :stream ,stream @@ -103,8 +107,9 @@ `(:break-characters ,break-var)) ,@(and after-line-break `(:after-line-break ,after-var))))) - (when ,initially-var - (write-string ,after-var ,stream)) + ,(unless (null after-line-break-initially) + `(when ,initially-var + (write-string ,after-var ,stream))) ,@body)) ,@args)))

1 0

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

15 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21582/Drei Modified Files: views.lisp Log Message: Delete the line cache when changing the buffer of a Drei buffer view. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/03 07:47:17 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/15 13:51:40 1.46 @@ -645,7 +645,7 @@ (defmethod (setf buffer) :after (buffer (view drei-buffer-view)) (invalidate-all-strokes view) - (with-accessors ((top top) (bot bot) + (with-accessors ((top top) (bot bot) (lines lines) (lines-prefix lines-prefix-size) (lines-suffix lines-suffix-size) (buffer-size last-seen-buffer-size)) view @@ -654,6 +654,7 @@ lines-prefix 0 lines-suffix 0 buffer-size 0) + (delete-elements* lines 0 (nb-elements lines)) (update-line-data view))) (defmethod cache-string :around ((view drei-buffer-view))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs May 2008