diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index 60364007e7c3e715deaa803134df4ba8eaaaa39e..435954ec81fb8e88d3b3c97e1d55c4c800e94f50 100644 --- a/clim/command-processor.lisp +++ b/clim/command-processor.lisp @@ -688,33 +688,37 @@ (start-position (and (input-editing-stream-p stream) (stream-scan-pointer stream))) (replace-input-p nil)) + ;;NOTE workaround for the define-presentation-method implementation doing code-walking + ;;in search for variables in presentation types' parameters and options. -- jacek.zlydach 2017-10-28 + auto-activate (multiple-value-bind (object type) (with-input-context (command-type) (command command-presentation-type nil options) - (with-input-context (form-type) (form form-presentation-type nil options) - (let ((gesture (read-gesture :stream stream :peek-p t))) - (cond ((and (characterp gesture) - (find gesture *command-dispatchers* :test #'char-equal)) - (read-gesture :stream stream) ;get out the colon - (apply #'accept command-type - :stream stream :prompt nil :view view - :history type args)) - (t (apply #'accept form-type - :stream stream :prompt nil :view view - :history type args)))) - (t (when (getf options :echo t) - (setq replace-input-p t)) - (values form form-presentation-type))) - (t (when (getf options :echo t) - (setq replace-input-p t)) - (when (partial-command-p command) - (setq command (funcall *partial-command-parser* - command command-table stream start-position))) - (when replace-input-p - (unless (stream-rescanning-p stream) - (replace-input stream (string (first *command-dispatchers*)) - :buffer-start start-position) - (incf start-position))) - (values command command-presentation-type))) + (with-input-context (form-type) (form form-presentation-type nil options) + (let ((gesture (read-gesture :stream stream :peek-p t))) + (cond ((and (characterp gesture) + (find gesture *command-dispatchers* :test #'char-equal)) + (read-gesture :stream stream) ;get out the colon + (apply #'accept command-type + :stream stream :prompt nil :view view + :history type args)) + (t + (apply #'accept form-type ;might this be missing? + :stream stream :prompt nil :view view + :history type args)))) + (t (when (getf options :echo t) + (setq replace-input-p t)) + (values form form-presentation-type))) + (t (when (getf options :echo t) + (setq replace-input-p t)) + (when (partial-command-p command) + (setq command (funcall *partial-command-parser* + command command-table stream start-position))) + (when replace-input-p + (unless (stream-rescanning-p stream) + (replace-input stream (string (first *command-dispatchers*)) + :buffer-start start-position) + (incf start-position))) + (values command command-presentation-type))) (when replace-input-p (presentation-replace-input stream object type view :buffer-start start-position)) diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index c1f760be5a95c93ad10d30e6cf1fe2b071e18ffa..ae52808e104b785dd8fc57c6a80d430f69c50f08 100644 --- a/clim/ptypes1.lisp +++ b/clim/ptypes1.lisp @@ -862,7 +862,7 @@ #+Clozure (cl:structure-class 'defstruct) ) name))) - (let (#+(or Genera Cloe-Runtime (and MCL CCL-2)) + (let (#+(or Genera Cloe-Runtime (and MCL CCL-2) sbcl) (class-name `(presentation-type ,name)) ) (setq class @@ -886,10 +886,8 @@ #+(and MCL CCL-2) (setf (slot-value class 'ccl::slots) (cons nil (vector))) ;; If the class name couldn't be set while making the class, set it now - ;; FIXME not sure what to do with this, commenting out for now. -- jacek.zlydach, 2017-05-06 - ;; #-(or Genera Cloe-Runtime Lucid aclpc (and MCL CCL-2) Clozure) - ;; (setf (class-name class) class-name) - )) + #-(or Genera Cloe-Runtime Lucid aclpc (and MCL CCL-2) Clozure) + (setf (class-name class) class-name))) ((not (or (equal (closer-mop:class-direct-superclasses class) direct-superclasses) ;; The above equal would suffice if it were not for the fact that when ;; a CLOS class in the compile-file environment has a superclass in the @@ -1568,7 +1566,7 @@ #+CLIM-extends-CLOS (defvar *presentation-method-argument-class*) -#+CLIM-extends-CLOS +#+(and Genera CLIM-extends-CLOS) (defmethod clos-internals::compute-effective-method-1 :around ((generic-function presentation-generic-function) methods argument-function) @@ -1614,13 +1612,9 @@ (:generic-function generic-function) (setq after (reverse after)) (labels ((method-class (method) - (let ((class (first (#-Clozure clos:method-specializers - #+Clozure ccl:method-specializers - method)))) + (let ((class (first (closer-mop:method-specializers method)))) (if (consp class) (second class) class)))) - (let* ((generic-function-name (#-Clozure clos:generic-function-name - #+Clozure ccl:generic-function-name - generic-function)) + (let* ((generic-function-name (closer-mop:generic-function-name generic-function)) (generic-lambda-list (block nil (maphash #'(lambda (key value) (declare (ignore key)) @@ -1634,7 +1628,7 @@ (class *presentation-method-argument-class*)) (multiple-value-bind (bindings alist) (generate-type-massagers class superclasses parameters options nil) - (labels ((call-method (method &optional (next-methods nil next-methods-p)) + (labels ((magic-call-method (method &optional (next-methods nil next-methods-p)) (setq next-methods ;massage call-next-method args also (mapcar #'(lambda (method) (if (atom method) @@ -1657,16 +1651,16 @@ `(:next-methods ,next-methods))) `(call-method ,method ,@(when next-methods-p `(,next-methods)))))) - (call-methods (methods) - (mapcar #'call-method methods))) + (magic-call-methods (methods) + (mapcar #'magic-call-method methods))) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 - (progn ,@(call-methods before) - ,(call-method (first primary) (rest primary))) - ,@(call-methods (reverse after))) - (call-method (first primary) ())))) + (progn ,@(magic-call-methods before) + ,(magic-call-method (first primary) (rest primary))) + ,@(magic-call-methods (reverse after))) + (magic-call-method (first primary) ())))) (when around - (setq form (call-method (first around) + (setq form (magic-call-method (first around) `(,@(rest around) (make-method ,form))))) (if bindings diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index 27e26dbbc56c0eb1c4ce9e2cfc9cb21f72d293a6..f04a183b2f6bc813903b91e0a4daaf94dc3afd55 100644 --- a/demo/puzzle.lisp +++ b/demo/puzzle.lisp @@ -43,7 +43,8 @@ (define-presentation-type puzzle-cell () :inherit-from '(integer 1 15)) -(define-presentation-method highlight-presentation ((type puzzle-cell) record stream state) +;;; NOTE disabled because it breaks displaying a list of demos due to "unknown type specifier" condition. -- jacek.zlydach 2017-10-28 +#+ignore(define-presentation-method highlight-presentation ((type puzzle-cell) record stream state) state (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates