Commit 73fc9538 authored by cer's avatar cer
Browse files

fixes

parents
This diff is collapsed.
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: accept.lisp,v 1.7 91/08/05 13:25:19 cer Exp $
(in-package :clim)
"Copyright (c) 1990, 1991 Symbolics, Inc. All rights reserved."
"Copyright (c) 1991, Franz Inc. All rights reserved"
(defun accept (type &rest accept-args
&key (stream *query-io*)
(view (stream-default-view stream))
(default nil default-supplied-p)
(default-type type)
(history type)
(provide-default nil)
(prompt t)
(prompt-mode ':normal)
(display-default prompt)
(query-identifier nil)
(activation-characters nil)
(additional-activation-characters nil)
(blip-characters nil)
(additional-blip-characters nil)
(present-p nil))
(declare (dynamic-extent accept-args))
(declare (values object type))
(declare (ignore view prompt prompt-mode display-default query-identifier
activation-characters additional-activation-characters
blip-characters additional-blip-characters present-p))
;; Allow the arguments to be presentation type abbreviations
(multiple-value-bind (expansion expanded)
(expand-presentation-type-abbreviation type)
(when expanded
(when (eq default-type type)
(setq default-type expansion))
(when (eql history type)
(setq history expansion))
(setq type expansion)))
(unless (eq default-type type)
(multiple-value-bind (expansion expanded)
(expand-presentation-type-abbreviation default-type)
(when expanded
(setq default-type expansion)
(setq accept-args `(:default-type ,default-type ,@accept-args)))))
(unless (eq history type)
(multiple-value-bind (expansion expanded)
(expand-presentation-type-abbreviation history)
(when expanded
(setq history expansion)
(setq accept-args `(:history ,history ,@accept-args)))))
(let ((insert-default nil))
(when (and provide-default (null default-supplied-p))
;; If the user wants a default, but provided none, go get it from the history
(let ((history (if (typep history 'basic-history)
history
(presentation-type-history history))))
(when history
(let ((element (yank-from-history history)))
(when element
(setq default (presentation-history-element-object element)
default-supplied-p t
insert-default t))))))
(when default-supplied-p
;; Massage the default
(multiple-value-bind (new-default new-type)
(presentation-default-preprocessor default type :default-type default-type)
(when (or (not (eq default new-default))
(not (eq default-type new-type)))
(setq default new-default
default-type (or new-type default-type)
insert-default t))))
(when insert-default
(setq accept-args `(:default ,default :default-type ,default-type ,@accept-args))))
;; Call methods to do the work
(with-rem-keywords (accept-args accept-args '(:stream))
(let ((query-identifier
(apply #'prompt-for-accept (or *original-stream* stream) type accept-args)))
(apply #'accept-1 (or *original-stream* stream) type
:query-identifier query-identifier accept-args))))
(defmethod accept-1 ((stream input-protocol-mixin) type &rest args)
(declare (dynamic-extent args))
(apply #'accept-2 (or *original-stream* stream) type args))
(defmethod prompt-for-accept ((stream input-protocol-mixin) type &rest args
&key query-identifier &allow-other-keys)
(declare (dynamic-extent args))
(when (output-stream-p stream)
(apply #'prompt-for-accept-internal stream type args))
query-identifier)
(defun prompt-for-accept-internal (stream type
&key (default nil default-supplied-p) (default-type type)
(prompt t) (prompt-mode ':normal)
(display-default prompt)
&allow-other-keys)
(cond ((eq prompt t)
(write-string "Enter " stream)
(describe-presentation-type type stream 1))
((not (eq prompt nil))
(write-string prompt stream)))
(when (and display-default default-supplied-p)
(when prompt (write-string " [" stream))
(write-string "default " stream)
(present default default-type :stream stream)
(when prompt (write-string "]" stream)))
(when (eq prompt-mode ':normal)
(when (or prompt (and display-default default-supplied-p))
(write-string ": " stream))))
(defun accept-2 (stream type
&key (view (stream-default-view stream))
(default nil default-supplied-p)
(default-type type)
((:history history-type) type)
(present-p nil)
(query-identifier nil)
(activation-characters nil)
(additional-activation-characters nil)
(blip-characters nil)
(additional-blip-characters nil)
&allow-other-keys)
;; Set up the input editing environment
(let ((the-object nil)
(the-type nil)
(activated t)
(history nil))
(cond ((typep history-type 'basic-history)
(setq history history-type
history-type type))
(history-type
(setq history (presentation-type-history history-type))))
;; In AVVs, ACCEPT can turn into PRESENT
(when present-p
(return-from accept-2
(accept-present-default type stream view default default-supplied-p
present-p query-identifier)))
(block input-editing
(flet ((input-sensitizer (continuation stream)
(declare (dynamic-extent continuation))
(if (stream-record-p stream)
(with-output-as-presentation (:type (or the-type type)
:stream stream
:object the-object)
(funcall continuation stream))
(funcall continuation stream))))
(declare (dynamic-extent #'input-sensitizer))
(with-input-editing (stream :input-sensitizer #'input-sensitizer)
(let ((start-position (input-position stream)))
(with-input-context (type)
(object presentation-type nil options)
(with-activation-characters ((or activation-characters
additional-activation-characters
*standard-activation-characters*)
:override (not (null activation-characters)))
(with-blip-characters ((or blip-characters
additional-blip-characters)
:override (not (null blip-characters)))
(handler-bind ((parse-error
#'(lambda (error)
(declare (ignore error))
(when (and default-supplied-p
(check-for-default stream start-position
default default-type
view))
(setq the-object default
the-type default-type)
(return-from input-editing))
;; Decline to handle the parse error
nil)))
(flet ((accept-help (stream action string-so-far)
(declare (ignore action string-so-far))
(write-string "You are being asked to enter " stream)
(describe-presentation-type type stream)
(write-char #\. stream)))
(declare (dynamic-extent #'accept-help))
(with-accept-help
(((:top-level-help :establish-unless-overridden)
;; :ESTABLISH-... here because we want (SEQUENCE PATHNAME)'s
;; help, not both (SEQUENCE PATHNAME) and PATHNAME.
#'accept-help))
;; Call the presentation type's ACCEPT method
(multiple-value-setq (the-object the-type)
(let ((*presentation-type-for-yanking* (and history history-type)))
(if default-supplied-p
(if history
(let ((default-element
(make-presentation-history-element
:object default :type default-type)))
(with-default-bound-in-history history default-element
(call-presentation-generic-function accept
type stream view
:default default :default-type default-type)))
(call-presentation-generic-function accept
type stream view
:default default :default-type default-type))
(call-presentation-generic-function accept
type stream view)))))))))
;; A presentation translator was invoked
(t
(setq the-object object
the-type presentation-type
activated nil)
(when (getf options :echo t)
(presentation-replace-input stream object presentation-type view
:buffer-start start-position
:query-identifier query-identifier))))))))
;; The input has been parsed, moused, or defaulted.
;; If we are still inside a WITH-INPUT-EDITING at an outer level, leave the
;; delimiter in the stream. But if this was the top level of input, eat
;; the activation character instead of leaving it in the stream.
;; Don't eat the activation character on streams that can't ever support
;; input editing, such as string streams.
;;--- This is really lousy. We need a coherent theory here.
(when activated
(when (and (not (interactive-stream-p stream))
(stream-supports-input-editing stream))
(let ((gesture (read-gesture :stream stream :timeout 0)))
;;--- For now, just ignore button release events
(when (typep gesture 'silica::pointer-release-event)
(read-gesture :stream stream :timeout 0)))))
(when (and history (frame-maintain-presentation-histories *application-frame*))
;;--- Should this only record stuff that was input via the keyboard?
(push-history-element history (make-presentation-history-element
:object the-object :type (or the-type type))))
#+compulsive-type-checking
(when (and the-type (not (eq the-type type)))
(unless (presentation-subtypep the-type type)
;; Catch a common bug by verifying that the returned type is a subtype
;; of the requested type
(cerror "Return a second value of ~*~*~*~S"
"The ~S method for the type ~S returned a second value of ~S, ~
which is not a subtype of ~S"
'accept type the-type type)
(setq the-type type)))
;; Ensure that there are no stale highlighting boxes lying around if
;; we are exiting via keyboard input
(when (output-recording-stream-p stream)
(unhighlight-highlighted-presentation stream t))
(values the-object (or the-type type))))
;;; If the input from stream, starting at location, is a request to use the default
;;; then insert the default and return true
(defun check-for-default (stream location default default-type view)
(setf (input-position stream) location)
(loop
(let ((char (read-gesture :stream stream)))
(when (or (not (characterp char))
(blip-character-p char)
(not (whitespace-character-p char)))
;; If we got some kind of mouse gesture or a blip character or
;; a printing character, then put it back and check to see if
;; we should insert the default.
(unread-gesture char :stream stream)
(setf (input-position stream) location)
(when (or (null char)
(activation-character-p char)
(blip-character-p char))
;; Insert the default if we got a character that will terminate
;; the current call to ACCEPT
(unless (rescanning-p stream)
(presentation-replace-input stream default default-type view
:buffer-start location))
(return-from check-for-default t))
(return-from check-for-default nil)))))
;;; As in DW, this does not do defaulting, but does accept a :default argument
;;; in case the accept method needs it (e.g. for pathnames)
(defun accept-from-string (type string &key (view +textual-view+)
(default nil default-supplied-p)
(default-type type)
(start 0)
(end nil))
(declare (values object type index))
;; Allow the arguments to be presentation type abbreviations
(multiple-value-bind (expansion expanded)
(expand-presentation-type-abbreviation type)
(when expanded
(when (eq default-type type)
(setq default-type expansion))
(setq type expansion)))
(unless (eq default-type type)
(multiple-value-bind (expansion expanded)
(expand-presentation-type-abbreviation default-type)
(when expanded
(setq default-type expansion))))
;; Call the presentation type's accept method
(let ((index start))
(multiple-value-bind (the-object the-type)
(with-input-from-string (stream string :start start :end end :index index)
(handler-bind ((simple-parse-error
#'(lambda (error)
;; This private version of CHECK-FOR-DEFAULT is
;; enough for string and string streams to do a
;; reasonable job, but it's not perfect. Some
;; hairy presentation types may still not work.
(flet ((check-for-default (stream)
(loop
(let ((char (read-char stream nil :eof)))
(when (or (not (characterp char))
(blip-character-p char)
(not (whitespace-character-p char)))
(unread-char char stream)
(when (or (eql char :eof)
(activation-character-p char)
(blip-character-p char))
(return-from check-for-default t))
(return-from check-for-default nil))))))
(declare (dynamic-extent #'check-for-default))
(when (check-for-default stream)
(return-from accept-from-string
(values default default-type index)))))))
(if default-supplied-p
(call-presentation-generic-function accept
type stream view
:default default :default-type default-type)
(call-presentation-generic-function accept type stream view))))
(values the-object (or the-type type) index))))
;; Make ACCEPT work inside WITH-INPUT-FROM-STRING
;; by defining methods that partially implement the extended stream input
;; protocol on input-from-string streams
(defmethod stream-read-gesture ((stream t)
&key timeout peek-p
input-wait-test input-wait-handler
pointer-button-press-handler)
(declare (ignore input-wait-test input-wait-handler pointer-button-press-handler))
(let ((char (if (eql timeout 0)
(stream-read-char-no-hang stream)
(stream-read-char stream))))
(when (and char peek-p)
(stream-unread-char stream char))
char))
(defmethod stream-unread-gesture ((stream t) gesture)
(unless (eq gesture ':eof)
(check-type gesture character)
(stream-unread-char stream gesture)))
(defmethod accept-1 ((stream t) type &rest args)
(declare (dynamic-extent args))
(apply #'accept-2 (or *original-stream* stream) type args))
(defmethod prompt-for-accept ((stream t) type &key query-identifier &allow-other-keys)
(declare (ignore type))
query-identifier)
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: basic-translators.lisp,v 1.1 91/09/09 18:42:21 cer Exp Locker: cer $
(in-package :clim)
"Copyright (c) 1990, 1991 Symbolics, Inc. All rights reserved."
"Copyright (c) 1991, Franz Inc. All rights reserved"
;; The translator that normally runs.
(define-presentation-translator identity
(t nil global-command-table
:tester ((presentation context-type)
(identity-translator-applicable-p presentation context-type))
:tester-definitive t
:documentation ((object presentation stream)
(let ((*print-length* 3)
(*print-level* 3)
(*print-pretty* nil))
(present object (presentation-type presentation) :stream stream)))
:gesture :select)
(object presentation)
(values object (presentation-type presentation)))
(defun identity-translator-applicable-p (presentation context-type)
(let* ((type (presentation-type presentation))
(type-name (presentation-type-name type))
(object (presentation-object presentation)))
(with-presentation-type-decoded (context-name context-parameters) context-type
(if (eq type-name 'blank-area)
(eq context-name 'blank-area)
;; Let MENU-ITEM-IDENTITY take care of pure menu items
(unless (and (eq type-name 'menu-item)
(eq context-name 'menu-item))
;; Either the types definitely match, or the types nominally match
;; and the object must be validated.
(or (presentation-subtypep type context-type)
(and (not (null context-parameters))
(presentation-subtypep type-name context-name)
(presentation-typep object context-type))))))))
(eval-when (compile load eval)
(warn "You really want to remove this"))
(define-presentation-type menu-item ())
;; This translator is here to compute menu item documentation
(define-presentation-translator menu-item-identity
(menu-item menu-item global-command-table
:priority 1 ;prefer this to IDENTITY
:tester-definitive t
:documentation ((object stream)
(let ((documentation (or (menu-item-documentation object)
(menu-item-display object))))
(write documentation :stream stream :escape nil)))
:gesture :select)
(object presentation)
(values object (presentation-type presentation)))
;; Only the PRESENTATION-MENU translator lives in this
(make-command-table 'presentation-menu-command-table :inherit-from nil)
;; If you change this, be sure to change the SETQ below
(define-presentation-action presentation-menu
(t nil presentation-menu-command-table
;; You might think that there should be a tester that sees if there
;; are any applicable translators. That's not necessary because
;; FIND-APPLICABLE-TRANSLATORS and PRESENTATION-MATCHES-CONTEXT-TYPE
;; treat this translator as a special case.
:documentation "Menu"
:menu nil ;this doesn't go into any menu
:gesture :menu)
(presentation frame window x y)
(call-presentation-menu presentation *input-context*
frame window x y
:for-menu t))
;; "the SETQ below"...
(setq *presentation-menu-translator*
(find-presentation-translator 'presentation-menu 'presentation-menu-command-table))
(defun call-presentation-menu (presentation input-context frame window x y
&key (for-menu t) label)
(let* ((translators (find-applicable-translators presentation input-context
frame window x y
:event nil :for-menu for-menu))
;; Yecch. The problem is each "translator stuff" is a list, which
;; is indistinguishable from the item syntax. Oh well, we're already
;; consing up stuff already...
(item-list
(and translators (map 'list
#'(lambda (thing)
(list thing :value thing))
translators))))
(when translators ;just in case...
(flet ((translator-documentation (translator-stuff stream)
(setq translator-stuff (menu-item-value translator-stuff))
(let* ((translator (pop translator-stuff))
(context-type (pop translator-stuff)))
(document-presentation-translator translator presentation context-type
frame nil window x y
:stream stream
;; Run the body if need be
:documentation-type :from-body))))
(declare (dynamic-extent #'translator-documentation))
(let ((chosen (menu-choose item-list
:associated-window window
:label label
:printer #'translator-documentation)))
(when chosen
;; Anticipate the day when we can move the mouse off the menu
(let* ((translator (pop chosen))
(context-type (pop chosen))
(tag (pop chosen)))
(multiple-value-bind (translated-object translated-type options)
(call-presentation-translator translator presentation context-type
frame nil window x y)
(throw tag (values translated-object
(or translated-type context-type)
nil ;would be an event...
options))))))))))
(defun quote-expression-if-necessary (object type)
(if (and (not (presentation-subtypep type 'form))
(or (consp object)
(and (symbolp object)
(not (keywordp object))
(not (eq object nil))
(not (eq object t)))))
(list 'quote object)
object))
;; Quote all but self-evaluating things when translating them.
;; This translates everything, not just the ones needing quoting, since
;; the IDENTITY translator's tester always fails for EXPRESSION to FORM.
(define-presentation-translator expression-to-form
(expression form global-command-table
:documentation
((object presentation stream)
(let ((*print-length* 3)
(*print-level* 3)
(*print-pretty* nil))
(present (quote-expression-if-necessary object (presentation-type presentation))
'expression :stream stream)))
:gesture :select)
(object presentation)
(quote-expression-if-necessary object (presentation-type presentation)))
;; Display some more of a history display
(define-presentation-action display-rest-of-history
(display-rest-of-history nil global-command-table
:gesture :select
:documentation "Display the rest of the history")
(object window)
(display-history-contents (first object) window
:start-index (second object) :string (third object)))
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
(in-package :clim-internals)
"Copyright (c) 1988, 1989, 1990 International Lisp Associates. All rights reserved."
(defmacro default-output-stream (stream &optional must-be-variable-macro-name)
`(cond ((member ,stream '(t nil))
(setq ,stream '*standard-output*))
,@(when must-be-variable-macro-name
`(((not (and (symbolp ,stream)
(not (keywordp ,stream))))
(warn "The stream argument to ~S, ~S, is invalid.~@
This argument must be a variable that can be bound to a new stream."
',must-be-variable-macro-name ,stream)
(setq ,stream '*standard-output*))))))
(defmacro default-query-stream (stream &optional must-be-variable-macro-name)
`(cond ((member ,stream '(t nil))
(setq ,stream '*query-io*))
,@(when must-be-variable-macro-name
`(((not (and (symbolp ,stream)
(not (keywordp ,stream))))
(warn "The stream argument to ~S, ~S, is invalid.~@
This argument must be a variable that can be bound to a new stream."
',must-be-variable-macro-name ,stream)
(setq ,stream '*query-io*))))))
(defun-inline position-translate (point dx dy)
(values (+ (point-x point) dx)
(+ (point-y point) dy)))
(defun-inline position-translate* (x y dx dy)
(values (+ x dx)
(+ y dy)))