Mercurial > hg > xemacs-beta

view lisp/gui.el @ 1292:f3437b56874d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-02-13 09:57:04 by ben] profile updates profile.c: Major reworking. Keep track of new information -- total function timing (includes descendants), GC usage, total GC usage (includes descendants). New functions to be called appropriately from eval.c, alloc.c to keep track of this information. Keep track of when we're actually in a function vs. in its profile, for more accurate timing counts. Track profile overhead separately. Create new mechanism for specifying "internal sections" that are tracked just like regular Lisp functions and even appear in the backtrace if `backtrace-with-internal-sections' is non-nil (t by default for error-checking builds). Add some KKCC information for the straight (non-Elisp) hash table used by profile, which contains Lisp objects in its keys -- but not used yet. Remove old ad-hoc methods for tracking garbage collection, redisplay (which was incorrect anyway when Lisp was called within these sections). Don't record any tick info when blocking under MS Windows, since the timer there is in real time rather than in process time. Make `start-profiling', `stop-profiling' interactive. Be consistent wrt. recursive functions and functions currently on the stack when starting or stopping -- together these make implementing the `total' values extremely difficult. When we start profiling, we act as if we just entered all the functions currently on the stack. Likewise when exiting. Create vars in_profile for tracking time spent inside of profiling, and profiling_lock for setting exclusive access to the main hash table when reading from it or modifying it. (protects against getting screwed up by the signal handle going off at the same time. profile.h: New file. Create macros for declaring internal profiling sections. lisp.h: Move profile-related stuff to profile.h. alloc.c: Keep track of total consing, for profile. Tell profile when we are consing. Use new profile-section method for noting garbage-collection. alloc.c: Abort if we attempt to call the allocator reentrantly. backtrace.h, eval.c: Add info for use by profile in the backtrace frame and transfer PUSH_BACKTRACE/POP_BACKTRACE from eval.c, for use with profile. elhash.c: Author comment. eval.c, lisp.h: New Lisp var `backtrace-with-internal-sections'. Set to t when error-checking is on. eval.c: When unwinding, eval.c: Report to profile when we are about-to-call and just-called wrt. a function. alloc.c, eval.c: Allow for "fake" backtrace frames, for internal sections (used by profile and `backtrace-with-internal-sections'. event-Xt.c, event-gtk.c, event-msw.c, event-tty.c: Record when we are actually blocking on an event, for profile's sake. event-stream.c: Record internal profiling sections for getting, dispatching events. extents.c: Record internal profiling sections for map_extents. hash.c, hash.h: Add pregrow_hash_table_if_necessary(). (Used in profile code since the signal handler is the main grower but can't allow a realloc(). We make sure, at critical points, that the table is large enough.) lread.c: Create internal profiling sections for `load' (which may be triggered internally by autoload, etc.). redisplay.c: Remove old profile_redisplay_flag. Use new macros to declare internal profiling section for redisplay. text.c: Use new macros to declare internal profiling sections for char-byte conversion and internal-external conversion. SEMI-UNRELATED CHANGES: ----------------------- text.c: Update the long comments.
author ben
date Thu, 13 Feb 2003 09:57:08 +0000
parents 79940b592197
children 308d34e9f07d
line wrap: on
line source

;;; gui.el --- Basic GUI functions for XEmacs.

;; Copyright (C) 1997 Free Software Foundation, Inc.
;; Copyright (C) 1996 Ben Wing

;; Maintainer: XEmacs Development Team
;; Keywords: internal, dumped
 
;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the 
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; This file is dumped with XEmacs (when window system support is compiled in).

;;; Code:

(defcustom dialog-frame-plist '(width 60 height 20)
  "Plist of frame properties for initially creating a dialog frame.
Properties specified here supersede the values given in
`default-frame-plist'."
  :type 'plist
  :group 'frames)

(defun make-dialog-frame (&optional props parent)
  "Create a frame suitable for use as a dialog box.
The frame is made a child of PARENT (defaults to the selected frame),
and has additional properties PROPS, as well as `dialog-frame-plist'.
Normally it also has no modelines, menubars, or toolbars."
  (or parent (setq parent (selected-frame)))
  (let* ((ftop (frame-property parent 'top))
	 (fleft (frame-property parent 'left))
	 (fwidth (frame-pixel-width parent))
	 (fheight (frame-pixel-height parent))
	 (fonth (font-height (face-font 'default)))
	 (fontw (font-width (face-font 'default)))
	 (props (append props dialog-frame-plist))
	 (dfheight (plist-get props 'height))
	 (dfwidth (plist-get props 'width))
	 ;; under FVWM at least, if I don't specify the initial position,
	 ;; it ends up always at (0, 0).  xwininfo doesn't tell me
	 ;; that there are any program-specified position hints, so
	 ;; it must be an FVWM bug.  So just be smashing and position
	 ;; in the center of the selected frame.
	 (frame (make-frame
		 (append props
			 `(popup ,parent initially-unmapped t
				 menubar-visible-p nil
				 has-modeline-p nil
				 default-toolbar-visible-p nil
				 default-gutter-visible-p nil
				 modeline-shadow-thickness 0
				 left ,(+ fleft (- (/ fwidth 2)
						   (/ (* dfwidth fontw)
						      2)))
				 top ,(+ ftop (- (/ fheight 2)
						 (/ (* dfheight fonth)
						    2))))))))
    (set-face-foreground 'modeline [default foreground] frame)
    (set-face-background 'modeline [default background] frame)
    (make-frame-visible frame)
    frame))

(defvar gui-button-shadow-thickness 2)

(defun gui-button-p (object)
  "True if OBJECT is a GUI button."
  (and (vectorp object)
       (> (length object) 0)
       (eq 'button (aref object 0))))

(make-face 'gui-button-face "Face used for gui buttons")
(if (not (face-differs-from-default-p 'gui-button-face))
    (progn
      (set-face-reverse-p 'gui-button-face t)
      (set-face-background 'gui-button-face '(((win color) . "grey75")))
      (set-face-foreground 'gui-button-face '(((win color) . "black")))))


(defun gui-button-action (instance action user-data)
  (let ((domain (image-instance-domain instance)))
    (with-current-buffer (if (windowp domain)
			     (window-buffer domain) nil)
      (funcall action user-data))))

(defun make-gui-button (string &optional action user-data)
  "Make a GUI button whose label is STRING and whose action is ACTION.
If the button is inserted in a buffer and then clicked on, and ACTION
is non-nil, ACTION will be called with one argument, USER-DATA.
When ACTION is called, the buffer containing the button is made current."
  (vector 'button
	  :descriptor string
	  :face 'gui-button-face
	  :callback-ex `(lambda (image-instance event)
			  (gui-button-action image-instance
					     (quote ,action)
					     (quote ,user-data)))))

(defun insert-gui-button (button &optional pos buffer)
  "Insert GUI button BUTTON at POS in BUFFER."
  (check-argument-type 'gui-button-p button)
  (if-fboundp 'make-annotation
      (make-annotation (make-glyph button)
		       pos 'text buffer nil)
    (error 'unimplemented "insert-gui-button requires `annotations' package")))
  

;;; gui.el ends here