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