--- /dev/null
+;;; gs.el --- interface to Ghostscript
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: internal
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This code is experimental. Don't use it.
+
+;;; Code:
+
+(defvar gs-program "gs"
+ "The name of the Ghostscript interpreter.")
+
+
+(defvar gs-device "x11"
+ "The Ghostscript device to use to produce images.")
+
+
+(defvar gs-options
+ '("-q"
+ ;"-dNOPAUSE"
+ "-dBATCH"
+ "-sDEVICE=<device>"
+ "<file>")
+ "List of command line arguments to pass to Ghostscript.
+Arguments may contain place-holders `<file>' for the name of the
+input file, and `<device>' for the device to use.")
+
+
+(defun gs-replace-in-string (string find repl)
+ "Return STRING with all occurrences of FIND replaced by REPL.
+FIND is a regular expression."
+ (while (string-match find string)
+ (setq string (replace-match repl nil t string)))
+ string)
+
+
+(defun gs-options (device file)
+ "Return a list of command line options with place-holders replaced.
+DEVICE is the value to substitute for the place-holder `<device>',
+FILE is the value to substitute for the place-holder `<file>'."
+ (mapcar #'(lambda (option)
+ (setq option (gs-replace-in-string option "<device>" device)
+ option (gs-replace-in-string option "<file>" file)))
+ gs-options))
+
+
+;; The GHOSTVIEW property (taken from gv 3.5.8).
+;;
+;; Type:
+;;
+;; STRING
+;;
+;; Parameters:
+;;
+;; BPIXMAP ORIENT LLX LLY URX URY XDPI YDPI [LEFT BOTTOM TOP RIGHT]
+;;
+;; Scanf format: "%d %d %d %d %d %d %f %f %d %d %d %d"
+;;
+;; Explanation of parameters:
+;;
+;; BPIXMAP: pixmap id of the backing pixmap for the window. If no
+;; pixmap is to be used, this parameter should be zero. This
+;; parameter must be zero when drawing on a pixmap.
+;;
+;; ORIENT: orientation of the page. The number represents clockwise
+;; rotation of the paper in degrees. Permitted values are 0, 90, 180,
+;; 270.
+;;
+;; LLX, LLY, URX, URY: Bounding box of the drawable. The bounding box
+;; is specified in PostScript points in default user coordinates.
+;;
+;; XDPI, YDPI: Resolution of window. (This can be derived from the
+;; other parameters, but not without roundoff error. These values are
+;; included to avoid this error.)
+;;
+;; LEFT, BOTTOM, TOP, RIGHT: (optional) Margins around the window.
+;; The margins extend the imageable area beyond the boundaries of the
+;; window. This is primarily used for popup zoom windows. I have
+;; encountered several instances of PostScript programs that position
+;; themselves with respect to the imageable area. The margins are
+;; specified in PostScript points. If omitted, the margins are
+;; assumed to be 0.
+
+(defun gs-width-in-pt (frame pixel-width)
+ "Return, on FRAME, pixel width PIXEL-WIDTH tranlated to pt."
+ (let ((mm (* (float pixel-width)
+ (/ (float (x-display-mm-width frame))
+ (float (x-display-pixel-width frame))))))
+ (/ (* 25.4 mm) 72.0)))
+
+
+(defun gs-height-in-pt (frame pixel-height)
+ "Return, on FRAME, pixel height PIXEL-HEIGHT tranlated to pt."
+ (let ((mm (* (float pixel-height)
+ (/ (float (x-display-mm-height frame))
+ (float (x-display-pixel-height frame))))))
+ (/ (* 25.4 mm) 72.0)))
+
+
+(defun gs-set-ghostview-window-prop (frame spec img-width img-height)
+ "Set the `GHOSTVIEW' window property of FRAME.
+SPEC is a GS image specification. IMG-WIDTH is the width of the
+requested image, and IMG-HEIGHT is the height of the requested
+image in pixels."
+ (let* ((box (plist-get (cdr spec) :bounding-box))
+ (llx (nth 0 box))
+ (lly (nth 1 box))
+ (urx (nth 2 box))
+ (ury (nth 3 box))
+ (rotation (or (plist-get (cdr spec) :rotate) 0))
+ ;; The pixel width IMG-WIDTH of the pixmap gives the
+ ;; dots, URX - LLX give the inch.
+ (in-width (/ (- urx llx) 72.0))
+ (in-height (/ (- ury lly) 72.0))
+ (xdpi (/ img-width in-width))
+ (ydpi (/ img-height in-height)))
+ (x-change-window-property "GHOSTVIEW"
+ (format "0 %d %d %d %d %d %g %g"
+ rotation llx lly urx ury xdpi ydpi)
+ frame)))
+
+
+(defun gs-set-ghostview-colors-window-prop (frame pixel-colors)
+ "Set the `GHOSTVIEW_COLORS' environment variable depending on FRAME."
+ (let ((mode (cond ((x-display-color-p frame) "Color")
+ ((x-display-grayscale-p frame) "Grayscale")
+ (t "Monochrome"))))
+ (x-change-window-property "GHOSTVIEW_COLORS"
+ (format "%s %s" mode pixel-colors))))
+
+
+;
+;;;###autoload
+(defun gs-load-image (frame spec img-width img-height window-and-pixmap-id
+ pixel-colors)
+ "Load a PS image for display on FRAME.
+SPEC is an image specification, IMG-HEIGHT and IMG-WIDTH are width
+and height of the image in pixels. WINDOW-AND-PIXMAP-ID is a string of
+the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful."
+ (unwind-protect
+ (let ((file (plist-get (cdr spec) :file))
+ gs)
+ (gs-set-ghostview-window-prop frame spec img-width img-height)
+ (gs-set-ghostview-colors-window-prop frame pixel-colors)
+ (setenv "GHOSTVIEW" window-and-pixmap-id)
+ (setq gs (apply 'start-process "gs" "*GS*" gs-program
+ (gs-options gs-device file)))
+ (process-kill-without-query gs)
+ gs)
+ nil))
+
+
+;(defun gs-put-tiger ()
+; (let* ((ps-file "/usr/local/share/ghostscript/5.10/examples/tiger.ps")
+; (spec `(image :type ghostscript
+; :pt-width 200 :pt-height 200
+; :bounding-box (22 171 567 738)
+; :file ,ps-file)))
+; (put-text-property 1 2 'display spec)))
+;
+
+(provide 'gs)
+
+;; gs.el ends here.
--- /dev/null
+;;; image.el --- image API
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(defconst image-type-regexps
+ '(("^/\\*.*XPM.\\*/" . xpm)
+ ("^P[1-6]" . pbm)
+ ("^GIF8" . gif)
+ ("JFIF" . jpeg)
+ ("^\211PNG\r\n" . png)
+ ("^#define" . xbm)
+ ("^\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
+ ("^%!PS" . ghostscript))
+ "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
+When the first bytes of an image file match REGEXP, it is assumed to
+be of image type IMAGE-TYPE.")
+
+
+;;;###autoload
+(defun image-type-from-file-header (file)
+ "Determine the type of image file FILE from its first few bytes.
+Value is a symbol specifying the image type, or nil if type cannot
+be determined."
+ (unless (file-name-directory file)
+ (setq file (concat data-directory file)))
+ (setq file (expand-file-name file))
+ (let ((header (with-temp-buffer
+ (insert-file-contents-literally file nil 0 256)
+ (buffer-string)))
+ (types image-type-regexps)
+ type)
+ (while (and types (null type))
+ (let ((regexp (car (car types)))
+ (image-type (cdr (car types))))
+ (when (string-match regexp header)
+ (setq type image-type))
+ (setq types (cdr types))))
+ type))
+
+
+;;;###autoload
+(defun image-type-available-p (type)
+ "Value is non-nil if image type TYPE is available.
+Image types are symbols like `xbm' or `jpeg'."
+ (not (null (memq type image-types))))
+
+
+;;;###autoload
+(defun create-image (file &optional type &rest props)
+ "Create an image which will be loaded from FILE.
+Optional TYPE is a symbol describing the image type. If TYPE is omitted
+or nil, try to determine the image file type from its first few bytes.
+If that doesn't work, use FILE's extension.as image type.
+Optional PROPS are additional image attributes to assign to the image,
+like, e.g. `:heuristic-mask t'.
+Value is the image created, or nil if images of type TYPE are not supported."
+ (unless (stringp file)
+ (error "Invalid image file name %s" file))
+ (unless (or type
+ (setq type (image-type-from-file-header file)))
+ (let ((extension (file-name-extension file)))
+ (unless extension
+ (error "Cannot determine image type"))
+ (setq type (intern extension))))
+ (unless (symbolp type)
+ (error "Invalid image type %s" type))
+ (when (image-type-available-p type)
+ (append (list 'image :type type :file file) props)))
+
+
+;;;###autoload
+(defun put-image (image pos &optional buffer area)
+ "Put image IMAGE in front of POS in BUFFER.
+IMAGE must be an image created with `create-image' or `defimage'.
+POS may be an integer or marker.
+BUFFER nil or omitted means use the current buffer.
+AREA is where to display the image. AREA nil or omitted means
+display it in the text area, a value of `left-margin' means
+display it in the left marginal area, a value of `right-margin'
+means display it in the right marginal area.
+IMAGE is displayed by putting an overlay into BUFFER with a
+`before-string' that has a `display' property whose value is the
+image."
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (unless (eq (car image) 'image)
+ (error "Not an image: %s" image))
+ (unless (or (null area) (memq area '(left-margin right-margin)))
+ (error "Invalid area %s" area))
+ (let ((overlay (make-overlay pos pos buffer))
+ (string (make-string 1 ?x))
+ (prop (if (null area) image (cons area image))))
+ (put-text-property 0 1 'display prop string)
+ (overlay-put overlay 'put-image t)
+ (overlay-put overlay 'before-string string)))
+
+
+;;;###autoload
+(defun insert-image (image &optional area)
+ "Insert IMAGE into current buffer at point.
+AREA is where to display the image. AREA nil or omitted means
+display it in the text area, a value of `left-margin' means
+display it in the left marginal area, a value of `right-margin'
+means display it in the right marginal area.
+IMAGE is displayed by inserting an \"x\" into the current buffer
+having a `display' property whose value is the image."
+ (unless (eq (car image) 'image)
+ (error "Not an image: %s" image))
+ (unless (or (null area) (memq area '(left-margin right-margin)))
+ (error "Invalid area %s" area))
+ (insert "x")
+ (add-text-properties (1- (point)) (point)
+ (list 'display (if (null area) image (cons area image))
+ 'rear-nonsticky (list 'display))))
+
+
+;;;###autoload
+(defun remove-images (start end &optional buffer)
+ "Remove images between START and END in BUFFER.
+Remove only images that were put in BUFFER with calls to `put-image'.
+BUFFER nil or omitted means use the current buffer."
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (let ((overlays (overlays-in start end)))
+ (while overlays
+ (let ((overlay (car overlays)))
+ (when (overlay-get overlay 'put-image)
+ (delete-overlay overlay)
+ (setq overlays (cdr overlays)))))))
+
+
+;;;###autoload
+(defmacro defimage (symbol specs &optional doc)
+ "Define SYMBOL as an image.
+
+SPECS is a list of image specifications. DOC is an optional
+documentation string.
+
+Each image specification in SPECS is a property list. The contents of
+a specification are image type dependent. All specifications must at
+least contain the properties `:type TYPE' and `:file FILE', where TYPE
+is a symbol specifying the image type, e.g. `xbm', and FILE is the
+file to load the image from. The first image specification whose TYPE
+is supported, and FILE exists, is used to define SYMBOL.
+
+Example:
+
+ (defimage test-image ((:type xpm :file \"~/test1.xpm\")
+ (:type xbm :file \"~/test1.xbm\")))"
+ (let (image)
+ (while (and specs (null image))
+ (let* ((spec (car specs))
+ (type (plist-get spec :type))
+ (file (plist-get spec :file)))
+ (when (and (image-type-available-p type) (stringp file))
+ (setq file (expand-file-name file))
+ (unless (file-name-absolute-p file)
+ (setq file (concat data-directory "/" file)))
+ (when (file-exists-p file)
+ (setq image (cons 'image spec))))
+ (setq specs (cdr specs))))
+ `(defvar ,symbol ',image ,doc)))
+
+
+(provide 'image)
+
+ ;; image.el ends here.
+
+
+
+
--- /dev/null
+;;; jit-lock.el --- just-in-time fontification.
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Gerd Moellmann <gerd@gnu.org>
+;; Keywords: faces files
+;; Version: 1.0
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Just-in-time fontification, triggered by C redisplay code.
+
+;;; Code:
+
+
+(require 'font-lock)
+
+(eval-when-compile
+ (defmacro with-buffer-prepared-for-font-lock (&rest body)
+ "Execute BODY in current buffer, overriding several variables.
+Preserves the `buffer-modified-p' state of the current buffer."
+ `(let ((modified (buffer-modified-p))
+ (buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-point-motion-hooks t)
+ before-change-functions
+ after-change-functions
+ deactivate-mark
+ buffer-file-name
+ buffer-file-truename)
+ ,@body
+ (set-buffer-modified-p modified))))
+
+
+\f
+;;; Customization.
+
+(defcustom jit-lock-chunk-size 500
+ "*Font-lock chunks of this many characters, or smaller."
+ :type 'integer
+ :group 'jit-lock)
+
+
+(defcustom jit-lock-stealth-time 3
+ "*Time in seconds to wait before beginning stealth fontification.
+Stealth fontification occurs if there is no input within this time.
+If nil, means stealth fontification is never performed.
+
+The value of this variable is used when JIT Lock mode is turned on."
+ :type '(choice (const :tag "never" nil)
+ (number :tag "seconds"))
+ :group 'jit-lock)
+
+
+(defcustom jit-lock-stealth-nice 0.125
+ "*Time in seconds to pause between chunks of stealth fontification.
+Each iteration of stealth fontification is separated by this amount of time,
+thus reducing the demand that stealth fontification makes on the system.
+If nil, means stealth fontification is never paused.
+To reduce machine load during stealth fontification, at the cost of stealth
+taking longer to fontify, you could increase the value of this variable.
+See also `jit-lock-stealth-load'."
+ :type '(choice (const :tag "never" nil)
+ (number :tag "seconds"))
+ :group 'jit-lock)
+
+
+(defcustom jit-lock-stealth-load
+ (if (condition-case nil (load-average) (error)) 200)
+ "*Load in percentage above which stealth fontification is suspended.
+Stealth fontification pauses when the system short-term load average (as
+returned by the function `load-average' if supported) goes above this level,
+thus reducing the demand that stealth fontification makes on the system.
+If nil, means stealth fontification is never suspended.
+To reduce machine load during stealth fontification, at the cost of stealth
+taking longer to fontify, you could reduce the value of this variable.
+See also `jit-lock-stealth-nice'."
+ :type (if (condition-case nil (load-average) (error))
+ '(choice (const :tag "never" nil)
+ (integer :tag "load"))
+ '(const :format "%t: unsupported\n" nil))
+ :group 'jit-lock)
+
+
+(defcustom jit-lock-stealth-verbose nil
+ "*If non-nil, means stealth fontification should show status messages."
+ :type 'boolean
+ :group 'jit-lock)
+
+
+(defcustom jit-lock-defer-contextually 'syntax-driven
+ "*If non-nil, means deferred fontification should be syntactically true.
+If nil, means deferred fontification occurs only on those lines modified. This
+means where modification on a line causes syntactic change on subsequent lines,
+those subsequent lines are not refontified to reflect their new context.
+If t, means deferred fontification occurs on those lines modified and all
+subsequent lines. This means those subsequent lines are refontified to reflect
+their new syntactic context, either immediately or when scrolling into them.
+If any other value, e.g., `syntax-driven', means deferred syntactically true
+fontification occurs only if syntactic fontification is performed using the
+buffer mode's syntax table, i.e., only if `font-lock-keywords-only' is nil.
+
+The value of this variable is used when JIT Lock mode is turned on."
+ :type '(choice (const :tag "never" nil)
+ (const :tag "always" t)
+ (other :tag "syntax-driven" syntax-driven))
+ :group 'jit-lock)
+
+
+\f
+;;; Variables that are not customizable.
+
+(defvar jit-lock-mode nil
+ "Non-nil means Just-in-time Lock mode is active.")
+(make-variable-buffer-local 'jit-lock-mode)
+
+
+(defvar jit-lock-first-unfontify-pos nil
+ "Consider text after this position as unfontified.")
+(make-variable-buffer-local 'jit-lock-first-unfontify-pos)
+
+
+(defvar jit-lock-stealth-timer nil
+ "Timer for stealth fontification in Just-in-time Lock mode.")
+
+
+\f
+;;; JIT lock mode
+
+;;;###autoload
+(defun jit-lock-mode (arg)
+ "Toggle Just-in-time Lock mode.
+With arg, turn Just-in-time Lock mode on if and only if arg is positive.
+Enable it automatically by customizing group `font-lock'.
+
+When Just-in-time Lock mode is enabled, fontification is different in the
+following ways:
+
+- Demand-driven buffer fontification triggered by Emacs C code.
+ This means initial fontification of the whole buffer does not occur.
+ Instead, fontification occurs when necessary, such as when scrolling
+ through the buffer would otherwise reveal unfontified areas. This is
+ useful if buffer fontification is too slow for large buffers.
+
+- Stealthy buffer fontification if `jit-lock-stealth-time' is non-nil.
+ This means remaining unfontified areas of buffers are fontified if Emacs has
+ been idle for `jit-lock-stealth-time' seconds, while Emacs remains idle.
+ This is useful if any buffer has any deferred fontification.
+
+- Deferred context fontification if `jit-lock-defer-contextually' is
+ non-nil. This means fontification updates the buffer corresponding to
+ true syntactic context, after `jit-lock-stealth-time' seconds of Emacs
+ idle time, while Emacs remains idle. Otherwise, fontification occurs
+ on modified lines only, and subsequent lines can remain fontified
+ corresponding to previous syntactic contexts. This is useful where
+ strings or comments span lines.
+
+Stealth fontification only occurs while the system remains unloaded.
+If the system load rises above `jit-lock-stealth-load' percent, stealth
+fontification is suspended. Stealth fontification intensity is controlled via
+the variable `jit-lock-stealth-nice' and `jit-lock-stealth-lines'."
+ (interactive "P")
+ (setq jit-lock-mode (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not jit-lock-mode)))
+ (cond ((and jit-lock-mode
+ (or (not (boundp 'font-lock-mode))
+ (not font-lock-mode)))
+ ;; If font-lock is not on, turn it on, with Just-in-time
+ ;; Lock mode as support mode; font-lock will call us again.
+ (let ((font-lock-support-mode 'jit-lock-mode))
+ (font-lock-mode t)))
+
+ ;; Turn Just-in-time Lock mode on.
+ (jit-lock-mode
+ ;; Setting `font-lock-fontified' makes font-lock believe the
+ ;; buffer is already fontified, so that it won't highlight
+ ;; the whole buffer.
+ (make-local-variable 'font-lock-fontified)
+ (setq font-lock-fontified t)
+
+ (setq jit-lock-first-unfontify-pos nil)
+
+ ;; Install an idle timer for stealth fontification.
+ (when (and jit-lock-stealth-time
+ (null jit-lock-stealth-timer))
+ (setq jit-lock-stealth-timer
+ (run-with-idle-timer jit-lock-stealth-time
+ jit-lock-stealth-time
+ 'jit-lock-stealth-fontify)))
+
+ ;; Add a hook for deferred contectual fontification.
+ (when (or (eq jit-lock-defer-contextually 'always)
+ (and (not (eq jit-lock-defer-contextually 'never))
+ (null font-lock-keywords-only)))
+ (add-hook 'after-change-functions 'jit-lock-after-change))
+
+ ;; Install the fontification hook.
+ (add-hook 'fontification-functions 'jit-lock-function))
+
+ ;; Turn Just-in-time Lock mode off.
+ (t
+ ;; Cancel our idle timer.
+ (when jit-lock-stealth-timer
+ (cancel-timer jit-lock-stealth-timer)
+ (setq jit-lock-stealth-timer nil))
+
+ ;; Remove hooks.
+ (remove-hook 'after-change-functions 'jit-lock-after-change)
+ (remove-hook 'fontification-functions 'jit-lock-function))))
+
+
+;;;###autoload
+(defun turn-on-jit-lock ()
+ "Unconditionally turn on Just-in-time Lock mode."
+ (jit-lock-mode 1))
+
+
+\f
+;;; On demand fontification.
+
+(defun jit-lock-function (start)
+ "Fontify current buffer starting at position START.
+This function is added to `fontification-functions' when `jit-lock-mode'
+is active."
+ (when jit-lock-mode
+ (with-buffer-prepared-for-font-lock
+ (let ((end (min (point-max) (+ start jit-lock-chunk-size)))
+ (parse-sexp-lookup-properties font-lock-syntactic-keywords)
+ (old-syntax-table (syntax-table))
+ (font-lock-beginning-of-syntax-function nil)
+ next)
+ (when font-lock-syntax-table
+ (set-syntax-table font-lock-syntax-table))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (save-match-data
+ (condition-case error
+ ;; Fontify chunks beginning at START. The end of a
+ ;; chunk is either `end', or the start of a region
+ ;; before `end' that has already been fontified.
+ (while start
+ ;; Determine the end of this chunk.
+ (setq next (or (text-property-any start end 'fontified t)
+ end))
+
+ ;; Goto to the start of the chunk. Make sure we
+ ;; start fontifying at the beginning of the line
+ ;; containing the chunk start because font-lock
+ ;; functions seem to expects this, if I believe
+ ;; lazy-lock.
+ (goto-char start)
+ (unless (bolp)
+ (beginning-of-line)
+ (setq start (point)))
+
+ ;; Fontify the chunk, and mark it as fontified.
+ (unwind-protect
+ (font-lock-fontify-region start end nil))
+
+ ;; Even if we got an error above, mark the region as
+ ;; fontified. If we get an error now, we're
+ ;; probably getting the same error the next time we
+ ;; try, so it's moot to try again.
+ (add-text-properties start next '(fontified t))
+
+ ;; Find the start of the next chunk, if any.
+ (setq start (text-property-any next end 'fontified nil)))
+
+ ((error quit)
+ (message "Fontifying region...%s" error))))))
+
+ ;; Restore previous buffer settings.
+ (set-syntax-table old-syntax-table)))))
+
+
+(defun jit-lock-after-fontify-buffer ()
+ "Mark the current buffer as fontified.
+Called from `font-lock-after-fontify-buffer."
+ (with-buffer-prepared-for-font-lock
+ (add-text-properties (point-min) (point-max) '(fontified t))))
+
+
+(defun jit-lock-after-unfontify-buffer ()
+ "Mark the current buffer as unfontified.
+Called from `font-lock-after-fontify-buffer."
+ (with-buffer-prepared-for-font-lock
+ (remove-text-properties (point-min) (point-max) '(fontified nil))))
+
+
+\f
+;;; Stealth fontification.
+
+(defsubst jit-lock-stealth-chunk-start (around)
+ "Return the start of the next chunk to fontify around position AROUND..
+Value is nil if there is nothing more to fontify."
+ (save-restriction
+ (widen)
+ (let ((prev (previous-single-property-change around 'fontified))
+ (next (text-property-any around (point-max) 'fontified nil))
+ (prop (get-text-property around 'fontified)))
+ (cond ((and (null prop)
+ (< around (point-max)))
+ ;; Text at position AROUND is not fontified. The value of
+ ;; prev, if non-nil, is the start of the region of
+ ;; unfontified text. As a special case, prop will always
+ ;; be nil at point-max. So don't handle that case here.
+ (max (or prev (point-min))
+ (- around jit-lock-chunk-size)))
+
+ ((null prev)
+ ;; Text at AROUND is fontified, and everything up to
+ ;; point-min is. Return the value of next. If that is
+ ;; nil, there is nothing left to fontify.
+ next)
+
+ ((or (null next)
+ (< (- around prev) (- next around)))
+ ;; We either have no unfontified text following AROUND, or
+ ;; the unfontified text in front of AROUND is nearer. The
+ ;; value of prev is the end of the region of unfontified
+ ;; text in front of AROUND.
+ (let ((start (previous-single-property-change prev 'fontified)))
+ (max (or start (point-min))
+ (- prev jit-lock-chunk-size))))
+
+ (t
+ next)))))
+
+
+(defun jit-lock-stealth-fontify ()
+ "Fontify buffers stealthily.
+This functions is called after Emacs has been idle for
+`jit-lock-stealth-time' seconds."
+ (unless (or executing-kbd-macro
+ (window-minibuffer-p (selected-window)))
+ (let ((buffers (buffer-list))
+ minibuffer-auto-raise
+ message-log-max)
+ (while (and buffers
+ (not (input-pending-p)))
+ (let ((buffer (car buffers)))
+ (setq buffers (cdr buffers))
+ (with-current-buffer buffer
+ (when jit-lock-mode
+ ;; This is funny. Calling sit-for with 3rd arg non-nil
+ ;; so that it doesn't redisplay, internally calls
+ ;; wait_reading_process_input also with a parameter
+ ;; saying "don't redisplay." Since this function here
+ ;; is called periodically, this effectively leads to
+ ;; process output not being redisplayed at all because
+ ;; redisplay_internal is never called. (That didn't
+ ;; work in the old redisplay either.) So, we learn that
+ ;; we mustn't call sit-for that way here. But then, we
+ ;; have to be cautious not to call sit-for in a widened
+ ;; buffer, since this could display hidden parts of that
+ ;; buffer. This explains the seemingly weird use of
+ ;; save-restriction/widen here.
+
+ (with-temp-message (if jit-lock-stealth-verbose
+ (concat "JIT stealth lock "
+ (buffer-name)))
+
+ ;; Perform deferred unfontification, if any.
+ (when jit-lock-first-unfontify-pos
+ (save-restriction
+ (widen)
+ (when (and (>= jit-lock-first-unfontify-pos (point-min))
+ (< jit-lock-first-unfontify-pos (point-max)))
+ (with-buffer-prepared-for-font-lock
+ (put-text-property jit-lock-first-unfontify-pos
+ (point-max) 'fontified nil))
+ (setq jit-lock-first-unfontify-pos nil))))
+
+ (let (start
+ (nice (or jit-lock-stealth-nice 0))
+ (point (point)))
+ (while (and (setq start
+ (jit-lock-stealth-chunk-start point))
+ (sit-for nice))
+
+ ;; Wait a little if load is too high.
+ (when (and jit-lock-stealth-load
+ (> (car (load-average)) jit-lock-stealth-load))
+ (sit-for (or jit-lock-stealth-time 30)))
+
+ ;; Unless there's input pending now, fontify.
+ (unless (input-pending-p)
+ (jit-lock-function start))))))))))))
+
+
+\f
+;;; Deferred fontification.
+
+(defun jit-lock-after-change (start end old-len)
+ "Mark the rest of the buffer as not fontified after a change.
+Installed on `after-change-functions'.
+START and END are the start and end of the changed text. OLD-LEN
+is the pre-change length.
+This function ensures that lines following the change will be refontified
+in case the syntax of those lines has changed. Refontification
+will take place when text is fontified stealthily."
+ ;; Don't do much here---removing text properties is too slow for
+ ;; fast typers, giving them the impression of Emacs not being
+ ;; very responsive.
+ (when jit-lock-mode
+ (setq jit-lock-first-unfontify-pos
+ (if jit-lock-first-unfontify-pos
+ (min jit-lock-first-unfontify-pos start)
+ start))))
+
+
+(provide 'jit-lock)
+
+;; jit-lock.el ends here
--- /dev/null
+;;; tooltip.el --- Show tooltip windows
+
+;; Copyright (C) 1997 Free Software Foundation, Inc.
+
+;; Author: Gerd Moellmann <gerd@acm.org>
+;; Keywords: help c mouse tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Put into your `.emacs'
+
+;; (require 'tooltip)
+;; (tooltip-mode 1)
+
+
+\f
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (require 'comint)
+ (require 'gud))
+
+(provide 'tooltip)
+
+\f
+;;; Customizable settings
+
+(defgroup tooltip nil
+ "Customization group for the `tooltip' package."
+ :group 'help
+ :group 'c
+ :group 'mouse
+ :group 'tools
+ :tag "Tool Tips")
+
+
+(defcustom tooltip-delay 1.0
+ "Seconds to wait before displaying a tooltip the first time."
+ :tag "Delay"
+ :type 'number
+ :group 'tooltip)
+
+
+(defcustom tooltip-short-delay 0.1
+ "Seconds to wait between subsequent tooltips on different items."
+ :tag "Short delay"
+ :type 'number
+ :group 'tooltip)
+
+
+(defcustom tooltip-recent-seconds 1
+ "Display tooltips after `tooltip-short-delay' if changing tip items
+within this many seconds."
+ :tag "Recent seconds"
+ :type 'number
+ :group 'tooltip)
+
+
+(defcustom tooltip-frame-parameters
+ '((name . "tooltip")
+ (foreground-color . "black")
+ (background-color . "lightyellow")
+ (internal-border-width . 5)
+ (border-color . "lightyellow")
+ (border-width . 1))
+ "Frame parameters used for tooltips."
+ :type 'sexp
+ :tag "Frame Parameters"
+ :group 'tooltip)
+
+
+(defcustom tooltip-gud-tips-p nil
+ "Non-nil means show tooltips in GUD sessions."
+ :type 'boolean
+ :tag "GUD"
+ :group 'tooltip)
+
+
+(defcustom tooltip-gud-modes '(gud-mode c-mode c++-mode)
+ "List of modes for which to enable GUD tips."
+ :type 'sexp
+ :tag "GUD modes"
+ :group 'tooltip)
+
+
+(defcustom tooltip-gud-display
+ '((eq (tooltip-event-buffer tooltip-gud-event)
+ (marker-buffer overlay-arrow-position)))
+ "List of forms determining where GUD tooltips are displayed.
+
+Forms in the list are combined with AND. The default is to display
+only tooltips in the buffer containing the overlay arrow."
+ :type 'sexp
+ :tag "GUD buffers predicate"
+ :group 'tooltip)
+
+
+\f
+;;; Variables that are not customizable.
+
+(defvar tooltip-hook nil
+ "Functions to call to display tooltips.
+Each function is called with one argument EVENT which is a copy of
+the last mouse movement event that occurred.")
+
+
+(defvar tooltip-timeout-id nil
+ "The id of the timeout started when Emacs becomes idle.")
+
+
+(defvar tooltip-last-mouse-motion-event nil
+ "A copy of the last mouse motion event seen.")
+
+
+(defvar tooltip-hide-time nil
+ "Time when the last tooltip was hidden.")
+
+
+(defvar tooltip-mode nil
+ "Non-nil means tooltip mode is on.")
+
+
+(defvar tooltip-gud-debugger nil
+ "The debugger for which we show tooltips.")
+
+
+\f
+;;; Event accessors
+
+(defun tooltip-event-buffer (event)
+ "Return the buffer over which event EVENT occurred.
+This might return nil if the event did not occur over a buffer."
+ (let ((window (posn-window (event-end event))))
+ (and window (window-buffer window))))
+
+
+\f
+;;; Switching tooltips on/off
+
+;; We don't set track-mouse globally because this is a big redisplay
+;; problem in buffers having a pre-command-hook or such installed,
+;; which does a set-buffer, like the summary buffer of Gnus. Calling
+;; set-buffer prevents redisplay optimizations, so every mouse motion
+;; would be accompanied by a full redisplay.
+
+;;;###autoload
+(defun tooltip-mode (&optional arg)
+ "Mode for tooltip display.
+With ARG, turn tooltip mode on if and only if ARG is positive."
+ (interactive "P")
+ (let* ((on (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not tooltip-mode)))
+ (hook-fn (if on 'add-hook 'remove-hook)))
+ (setq tooltip-mode on)
+ (funcall hook-fn 'change-major-mode-hook 'tooltip-change-major-mode)
+ (tooltip-activate-mouse-motions-if-enabled)
+ (funcall hook-fn 'pre-command-hook 'tooltip-hide)
+ (funcall hook-fn 'tooltip-hook 'tooltip-gud-tips)
+ (funcall hook-fn 'tooltip-hook 'tooltip-help-tips)
+ (setq show-help-function (if on 'tooltip-show-help-function nil))
+ ;; `ignore' is the default binding for mouse movements.
+ (define-key global-map [mouse-movement]
+ (if on 'tooltip-mouse-motion 'ignore))
+ (when (and on tooltip-gud-tips-p)
+ (global-set-key [S-mouse-3] 'tooltip-gud-toggle-dereference)
+ (add-hook 'gdb-mode-hook
+ #'(lambda () (setq tooltip-gud-debugger 'gdb)))
+ (add-hook 'sdb-mode-hook
+ #'(lambda () (setq tooltip-gud-debugger 'sdb)))
+ (add-hook 'dbx-mode-hook
+ #'(lambda () (setq tooltip-gud-debugger 'dbx)))
+ (add-hook 'xdb-mode-hook
+ #'(lambda () (setq tooltip-gud-debugger 'xdb)))
+ (add-hook 'perldb-mode-hook
+ #'(lambda () (setq tooltip-gud-debugger 'perldb))))))
+
+
+\f
+;;; Timeout for tooltip display
+
+(defun tooltip-float-time ()
+ "Return the values of `current-time' as a float."
+ (let ((now (current-time)))
+ (+ (* 65536.0 (nth 0 now))
+ (nth 1 now)
+ (/ (nth 2 now) 1000000.0))))
+
+
+(defun tooltip-delay ()
+ "Return the delay in seconds for the next tooltip."
+ (let ((delay tooltip-delay)
+ (now (tooltip-float-time)))
+ (when (and tooltip-hide-time
+ (< (- now tooltip-hide-time) tooltip-recent-seconds))
+ (setq delay tooltip-short-delay))
+ delay))
+
+
+(defun tooltip-disable-timeout ()
+ "Disable the tooltip timeout."
+ (when tooltip-timeout-id
+ (disable-timeout tooltip-timeout-id)
+ (setq tooltip-timeout-id nil)))
+
+
+(defun tooltip-add-timeout ()
+ "Add a one-shot timeout to call function tooltip-timeout."
+ (setq tooltip-timeout-id
+ (add-timeout (tooltip-delay) 'tooltip-timeout nil)))
+
+
+(defun tooltip-timeout (object)
+ "Function called when timer with id tooltip-timeout-id fires."
+ (run-hook-with-args-until-success 'tooltip-hook
+ tooltip-last-mouse-motion-event))
+
+
+\f
+;;; Reacting on mouse movements
+
+(defun tooltip-change-major-mode ()
+ "Function added to `change-major-mode-hook' when tooltip mode is on."
+ (add-hook 'post-command-hook 'tooltip-activate-mouse-motions-if-enabled))
+
+
+(defun tooltip-activate-mouse-motions-if-enabled ()
+ "Reconsider for all buffers whether mouse motion events are desired."
+ (remove-hook 'post-command-hook 'tooltip-activate-mouse-motions-if-enabled)
+ (let ((buffers (buffer-list)))
+ (save-excursion
+ (while buffers
+ (set-buffer (car buffers))
+ (if (and tooltip-mode
+ tooltip-gud-tips-p
+ (memq major-mode tooltip-gud-modes))
+ (tooltip-activate-mouse-motions t)
+ (tooltip-activate-mouse-motions nil))
+ (setq buffers (cdr buffers))))))
+
+
+(defun tooltip-activate-mouse-motions (activatep)
+ "Activate/deactivate mouse motion events for the current buffer.
+ACTIVATEP non-nil means activate mouse motion events."
+ (if activatep
+ (progn
+ (make-local-variable 'track-mouse)
+ (setq track-mouse t))
+ (kill-local-variable 'track-mouse)))
+
+
+(defun tooltip-mouse-motion (event)
+ "Command handler for mouse movement events in `global-map'."
+ (interactive "e")
+ (tooltip-hide)
+ (when (car (mouse-pixel-position))
+ (setq tooltip-last-mouse-motion-event (copy-sequence event))
+ (tooltip-add-timeout)))
+
+
+\f
+;;; Displaying tips
+
+(defun tooltip-show (text)
+ "Show a tooltip window at the current mouse position displaying TEXT."
+ (x-show-tip text (selected-frame) tooltip-frame-parameters))
+
+
+(defun tooltip-hide (&optional ignored-arg)
+ "Hide a tooltip, if one is displayed.
+Value is non-nil if tooltip was open."
+ (tooltip-disable-timeout)
+ (when (x-hide-tip)
+ (setq tooltip-hide-time (tooltip-float-time))))
+
+
+\f
+;;; Debugger-related functions
+
+(defun tooltip-identifier-from-point (point)
+ "Extract the identifier at POINT, if any.
+Value is nil if no identifier exists at point. Identifier extraction
+is based on the current syntax table."
+ (save-excursion
+ (goto-char point)
+ (let ((start (progn (skip-syntax-backward "w_") (point))))
+ (unless (looking-at "[0-9]")
+ (skip-syntax-forward "w_")
+ (when (> (point) start)
+ (buffer-substring start (point)))))))
+
+
+(defmacro tooltip-region-active-p ()
+ "Value is non-nil if the region is currently active."
+ (if (string-match "^GNU" (emacs-version))
+ `(and transient-mark-mode mark-active)
+ `(region-active-p)))
+
+
+(defun tooltip-expr-to-print (event)
+ "Return an expression that should be printed for EVENT.
+If a region is active and the mouse is inside the region, print
+the region. Otherwise, figure out the identifier around the point
+where the mouse is."
+ (save-excursion
+ (set-buffer (tooltip-event-buffer event))
+ (let ((point (posn-point (event-end event))))
+ (if (tooltip-region-active-p)
+ (when (and (<= (region-beginning) point) (<= point (region-end)))
+ (buffer-substring (region-beginning) (region-end)))
+ (tooltip-identifier-from-point point)))))
+
+
+(defun tooltip-process-prompt-regexp (process)
+ "Return regexp matching the prompt of PROCESS at the end of a string.
+The prompt is taken from the value of COMINT-PROMPT-REGEXP in the buffer
+of PROCESS."
+ (let ((prompt-regexp (save-excursion
+ (set-buffer (process-buffer process))
+ comint-prompt-regexp)))
+ ;; Most start with `^' but the one for `sdb' cannot be easily
+ ;; stripped. Code the prompt for `sdb' fixed here.
+ (if (= (aref prompt-regexp 0) ?^)
+ (setq prompt-regexp (substring prompt-regexp 1))
+ (setq prompt-regexp "\\*"))
+ (concat "\n*" prompt-regexp "$")))
+
+
+(defun tooltip-strip-prompt (process output)
+ "Return OUTPUT with any prompt of PROCESS stripped from its end."
+ (let ((prompt-regexp (tooltip-process-prompt-regexp process)))
+ (save-match-data
+ (when (string-match prompt-regexp output)
+ (setq output (substring output 0 (match-beginning 0)))))
+ output))
+
+
+\f
+;;; Tips for `gud'
+
+(defvar tooltip-gud-original-filter nil
+ "Process filter to restore after GUD output has been received.")
+
+
+(defvar tooltip-gud-dereference nil
+ "Non-nil means print expressions with a `*' in front of them.
+For C this would dereference a pointer expression.")
+
+
+(defvar tooltip-gud-event nil
+ "The mouse movement event that led to a tooltip display.
+This event can be examined by forms in TOOLTIP-GUD-DISPLAY.")
+
+
+(defvar tooltip-gud-debugger nil
+ "A symbol describing the debugger running under GUD.")
+
+
+(defun tooltip-gud-toggle-dereference ()
+ "Toggle whether tooltips should show `* exor' or `expr'."
+ (interactive)
+ (setq tooltip-gud-dereference (not tooltip-gud-dereference))
+ (when (interactive-p)
+ (message "Dereferencing is now %s."
+ (if tooltip-gud-dereference "on" "off"))))
+
+
+(defun tooltip-gud-process-output (process output)
+ "Process debugger output and show it in a tooltip window."
+ (set-process-filter process tooltip-gud-original-filter)
+ (tooltip-show (tooltip-strip-prompt process output)))
+
+
+(defun tooltip-gud-print-command (expr)
+ "Return a suitable command to print the expression EXPR.
+If TOOLTIP-GUD-DEREFERENCE is t, also prepend a `*' to EXPR."
+ (when tooltip-gud-dereference
+ (setq expr (concat "*" expr)))
+ (case tooltip-gud-debugger
+ ((gdb dbx) (concat "print " expr))
+ (xdb (concat "p " expr))
+ (sdb (concat expr "/"))
+ (perldb expr)))
+
+
+(defun tooltip-gud-tips (event)
+ "Show tip for identifier or selection under the mouse. The mouse
+must either point at an identifier or inside a selected region for the
+tip window to be shown. If tooltip-gud-dereference is t, add a `*' in
+front of the printed expression.
+
+This function must return nil if it doesn't handle EVENT."
+ (let (gud-buffer process)
+ (when (and (eventp event)
+ tooltip-gud-tips-p
+ (boundp 'gud-comint-buffer)
+ (setq gud-buffer gud-comint-buffer)
+ (setq process (get-buffer-process gud-buffer))
+ (posn-point (event-end event))
+ (progn (setq tooltip-gud-event event)
+ (eval (cons 'and tooltip-gud-display))))
+ (let ((expr (tooltip-expr-to-print event)))
+ (when expr
+ (setq tooltip-gud-original-filter (process-filter process))
+ (set-process-filter process 'tooltip-gud-process-output)
+ (process-send-string
+ process (concat (tooltip-gud-print-command expr) "\n"))
+ expr)))))
+
+
+\f
+;;; Tooltip help.
+
+(defvar tooltip-help-message nil
+ "The last help message received via `tooltip-show-help-function'.")
+
+
+(defun tooltip-show-help-function (msg)
+ "Function installed as `show-help-function'.
+MSG is either a help string to display, or nil to cancel the display."
+ (let ((previous-help tooltip-help-message))
+ (setq tooltip-help-message msg)
+ (cond ((null msg)
+ (tooltip-hide))
+ ((or (not (stringp previous-help))
+ (not (string= msg previous-help)))
+ (tooltip-hide)
+ (tooltip-add-timeout))
+ (t
+ (tooltip-disable-timeout)
+ (tooltip-add-timeout)))))
+
+
+(defun tooltip-help-tips (event)
+ "Hook function to display a help tooltip.
+Value is non-nil if this function handled the tip."
+ (when (stringp tooltip-help-message)
+ (tooltip-show tooltip-help-message)
+ (setq tooltip-help-message nil)
+ t))
+
+
+\f
+;;; Do this after all functions have been defined that are called
+;;; from `tooltip-mode'.
+
+(defcustom tooltip-active nil
+ "*Non-nil means tooltips are active."
+ :tag "Activate tooltips"
+ :type 'boolean
+ :set #'(lambda (symbol value)
+ (set-default symbol value)
+ (tooltip-mode (or value 0)))
+ :require 'tooltip
+ :group 'tooltip)
+
+
+;;; tooltip.el ends here
--- /dev/null
+/* sound.c -- sound support.
+ Copyright (C) 1998 Free Software Foundation.
+
+This file is part of GNU Emacs.
+
+GNU Emacs 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.
+
+GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* Written by Gerd Moellmann <gerd@gnu.org>. Tested with Luigi's
+ driver on FreeBSD 2.2.7 with a SoundBlaster 16. */
+
+#include <config.h>
+
+#if defined HAVE_SOUND
+
+#include <lisp.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <dispextern.h>
+#include <errno.h>
+
+/* FreeBSD has machine/soundcard.h. Voxware sound driver docs mention
+ sys/soundcard.h. So, let's try whatever's there. */
+
+#ifdef HAVE_MACHINE_SOUNDCARD_H
+#include <machine/soundcard.h>
+#endif
+#ifdef HAVE_SYS_SOUNDCARD_H
+#include <sys/soundcard.h>
+#endif
+
+#define max(X, Y) ((X) > (Y) ? (X) : (Y))
+#define min(X, Y) ((X) < (Y) ? (X) : (Y))
+#define abs(X) ((X) < 0 ? -(X) : (X))
+
+/* Structure forward declarations. */
+
+struct sound_file;
+struct sound_device;
+
+/* The file header of RIFF-WAVE files (*.wav). Files are always in
+ little-endian byte-order. */
+
+struct wav_header
+{
+ u_int32_t magic;
+ u_int32_t length;
+ u_int32_t chunk_type;
+ u_int32_t chunk_format;
+ u_int32_t chunk_length;
+ u_int16_t format;
+ u_int16_t channels;
+ u_int32_t sample_rate;
+ u_int32_t bytes_per_second;
+ u_int16_t sample_size;
+ u_int16_t precision;
+ u_int32_t chunk_data;
+ u_int32_t data_length;
+};
+
+/* The file header of Sun adio files (*.au). Files are always in
+ big-endian byte-order. */
+
+struct au_header
+{
+ /* ASCII ".snd" */
+ u_int32_t magic_number;
+
+ /* Offset of data part from start of file. Minimum value is 24. */
+ u_int32_t data_offset;
+
+ /* Size of data part, 0xffffffff if unknown. */
+ u_int32_t data_size;
+
+ /* Data encoding format.
+ 1 8-bit ISDN u-law
+ 2 8-bit linear PCM (REF-PCM)
+ 3 16-bit linear PCM
+ 4 24-bit linear PCM
+ 5 32-bit linear PCM
+ 6 32-bit IEEE floating-point
+ 7 64-bit IEEE floating-point
+ 23 8-bit u-law compressed using CCITT 0.721 ADPCM voice data
+ encoding scheme. */
+ u_int32_t encoding;
+
+ /* Number of samples per second. */
+ u_int32_t sample_rate;
+
+ /* Number of interleaved channels. */
+ u_int32_t channels;
+};
+
+/* Maximum of all sound file headers sizes. */
+
+#define MAX_SOUND_HEADER_BYTES \
+ max (sizeof (struct wav_header), sizeof (struct au_header))
+
+/* Interface structure for sound devices. */
+
+struct sound_device
+{
+ /* The name of the device or null meaning use a default device name. */
+ char *file;
+
+ /* File descriptor of the device. */
+ int fd;
+
+ /* Device-dependent format. */
+ int format;
+
+ /* Volume (0..100). Zero means unspecified. */
+ int volume;
+
+ /* Sample size. */
+ int sample_size;
+
+ /* Sample rate. */
+ int sample_rate;
+
+ /* Bytes per second. */
+ int bps;
+
+ /* 1 = mono, 2 = stereo, 0 = don't set. */
+ int channels;
+
+ /* Open device SD. */
+ void (* open) P_ ((struct sound_device *sd));
+
+ /* Close device SD. */
+ void (* close) P_ ((struct sound_device *sd));
+
+ /* Configure SD accoring to device-dependent parameters. */
+ void (* configure) P_ ((struct sound_device *device));
+
+ /* Choose a device-dependent format for outputting sound file SF. */
+ void (* choose_format) P_ ((struct sound_device *sd,
+ struct sound_file *sf));
+
+ /* Write NYBTES bytes from BUFFER to device SD. */
+ void (* write) P_ ((struct sound_device *sd, char *buffer, int nbytes));
+
+ /* A place for devices to store additional data. */
+ void *data;
+};
+
+/* An enumerator for each supported sound file type. */
+
+enum sound_type
+{
+ RIFF,
+ SUN_AUDIO
+};
+
+/* Interface structure for sound files. */
+
+struct sound_file
+{
+ /* The type of the file. */
+ enum sound_type type;
+
+ /* File descriptor of the file. */
+ int fd;
+
+ /* Pointer to sound file header. This contains the first
+ MAX_SOUND_HEADER_BYTES read from the file. */
+ char *header;
+
+ /* Play sound file SF on device SD. */
+ void (* play) P_ ((struct sound_file *sf, struct sound_device *sd));
+};
+
+/* Indices of attributes in a sound attributes vector. */
+
+enum sound_attr
+{
+ SOUND_FILE,
+ SOUND_DEVICE,
+ SOUND_VOLUME,
+ SOUND_ATTR_SENTINEL
+};
+
+/* Symbols. */
+
+extern Lisp_Object QCfile;
+Lisp_Object QCvolume, QCdevice;
+Lisp_Object Qsound;
+Lisp_Object Qplay_sound_hook;
+
+/* These are set during `play-sound' so that sound_cleanup has
+ access to them. */
+
+struct sound_device *sound_device;
+struct sound_file *sound_file;
+
+/* Function prototypes. */
+
+static void vox_open P_ ((struct sound_device *));
+static void vox_configure P_ ((struct sound_device *));
+static void vox_close P_ ((struct sound_device *sd));
+static void vox_choose_format P_ ((struct sound_device *, struct sound_file *));
+static void vox_init P_ ((struct sound_device *));
+static void vox_write P_ ((struct sound_device *, char *, int));
+static void sound_perror P_ ((char *));
+static int parse_sound P_ ((Lisp_Object, Lisp_Object *));
+static void find_sound_file_type P_ ((struct sound_file *));
+static u_int32_t le2hl P_ ((u_int32_t));
+static u_int16_t le2hs P_ ((u_int16_t));
+static u_int32_t be2hl P_ ((u_int32_t));
+static u_int16_t be2hs P_ ((u_int16_t));
+static int wav_init P_ ((struct sound_file *));
+static void wav_play P_ ((struct sound_file *, struct sound_device *));
+static int au_init P_ ((struct sound_file *));
+static void au_play P_ ((struct sound_file *, struct sound_device *));
+
+
+\f
+/***********************************************************************
+ General
+ ***********************************************************************/
+
+/* Like perror, but signals an error. */
+
+static void
+sound_perror (msg)
+ char *msg;
+{
+ error ("%s: %s", msg, strerror (errno));
+}
+
+
+/* Parse sound specification SOUND, and fill ATTRS with what is
+ found. Value is non-zero if SOUND Is a valid sound specification.
+ A valid sound specification is a list starting with the symbol
+ `sound'. The rest of the list is a property list which may
+ contain the following key/value pairs:
+
+ - `:file FILE'
+
+ FILE is the sound file to play. If it isn't an absolute name,
+ it's searched under `data-directory'.
+
+ - `:device DEVICE'
+
+ DEVICE is the name of the device to play on, e.g. "/dev/dsp2".
+ If not specified, a default device is used.
+
+ - `:volume VOL'
+
+ VOL must be an integer in the range 0..100. */
+
+static int
+parse_sound (sound, attrs)
+ Lisp_Object sound;
+ Lisp_Object *attrs;
+{
+ /* SOUND must be a list starting with the symbol `sound'. */
+ if (!CONSP (sound) || !EQ (XCAR (sound), Qsound))
+ return 0;
+
+ sound = XCDR (sound);
+ attrs[SOUND_FILE] = Fplist_get (sound, QCfile);
+ attrs[SOUND_DEVICE] = Fplist_get (sound, QCdevice);
+ attrs[SOUND_VOLUME] = Fplist_get (sound, QCvolume);
+
+ /* File name must be specified. */
+ if (!STRINGP (attrs[SOUND_FILE]))
+ return 0;
+
+ /* Volume must be in the range 0..100 or unspecified. */
+ if (!NILP (attrs[SOUND_VOLUME]))
+ {
+ if (!INTEGERP (attrs[SOUND_VOLUME]))
+ return 0;
+ if (XINT (attrs[SOUND_VOLUME]) < 0
+ || XINT (attrs[SOUND_VOLUME]) > 100)
+ return 0;
+ }
+
+ /* Device must be a string or unspecified. */
+ if (!NILP (attrs[SOUND_DEVICE])
+ && !STRINGP (attrs[SOUND_DEVICE]))
+ return 0;
+
+ return 1;
+}
+
+
+/* Find out the type of the sound file whose file descriptor is FD.
+ SF is the sound file structure to fill in. */
+
+static void
+find_sound_file_type (sf)
+ struct sound_file *sf;
+{
+ if (!wav_init (sf)
+ && !au_init (sf))
+ error ("Unknown sound file format");
+}
+
+
+/* Function installed by play-sound with record_unwind_protect. */
+
+static Lisp_Object
+sound_cleanup (arg)
+ Lisp_Object arg;
+{
+ if (sound_device)
+ {
+ sound_device->close (sound_device);
+ if (sound_file->fd > 0)
+ close (sound_file->fd);
+ }
+}
+
+
+DEFUN ("play-sound", Fplay_sound, Splay_sound, 1, 1, 0,
+ "Play sound SOUND.")
+ (sound)
+ Lisp_Object sound;
+{
+ Lisp_Object attrs[SOUND_ATTR_SENTINEL];
+ char *header;
+ Lisp_Object file;
+ struct gcpro gcpro1, gcpro2;
+ int nbytes;
+ char *msg;
+ struct sound_device sd;
+ struct sound_file sf;
+ Lisp_Object args[2];
+ int count = specpdl_ptr - specpdl;
+
+ file = Qnil;
+ GCPRO2 (sound, file);
+ bzero (&sd, sizeof sd);
+ bzero (&sf, sizeof sf);
+ sf.header = (char *) alloca (MAX_SOUND_HEADER_BYTES);
+
+ sound_device = &sd;
+ sound_file = &sf;
+ record_unwind_protect (sound_cleanup, Qnil);
+
+ /* Parse the sound specification. Give up if it is invalid. */
+ if (!parse_sound (sound, attrs))
+ {
+ UNGCPRO;
+ error ("Invalid sound specification");
+ }
+
+ /* Open the sound file. */
+ sf.fd = openp (Fcons (Vdata_directory, Qnil),
+ attrs[SOUND_FILE], "", &file, 0);
+ if (sf.fd < 0)
+ sound_perror ("Open sound file");
+
+ /* Read the first bytes from the file. */
+ nbytes = read (sf.fd, sf.header, MAX_SOUND_HEADER_BYTES);
+ if (nbytes < 0)
+ sound_perror ("Reading sound file header");
+
+ /* Find out the type of sound file. Give up if we can't tell. */
+ find_sound_file_type (&sf);
+
+ /* Set up a device. */
+ if (STRINGP (attrs[SOUND_DEVICE]))
+ {
+ int len = XSTRING (attrs[SOUND_DEVICE])->size;
+ sd.file = (char *) alloca (len + 1);
+ strcpy (sd.file, XSTRING (attrs[SOUND_DEVICE])->data);
+ }
+ if (INTEGERP (attrs[SOUND_VOLUME]))
+ sd.volume = XFASTINT (attrs[SOUND_VOLUME]);
+
+ args[0] = Qplay_sound_hook;
+ args[1] = sound;
+ Frun_hook_with_args (make_number (2), args);
+
+ vox_init (&sd);
+ sd.open (&sd);
+
+ sf.play (&sf, &sd);
+ close (sf.fd);
+ sf.fd = -1;
+ sd.close (&sd);
+ sound_device = NULL;
+ sound_file = NULL;
+ UNGCPRO;
+ unbind_to (count, Qnil);
+ return Qnil;
+}
+
+\f
+/***********************************************************************
+ Byte-order Conversion
+ ***********************************************************************/
+
+/* Convert 32-bit value VALUE which is in little-endian byte-order
+ to host byte-order. */
+
+static u_int32_t
+le2hl (value)
+ u_int32_t value;
+{
+#ifdef WORDS_BIG_ENDIAN
+ unsigned char *p = (unsigned char *) &value;
+ value = p[0] + (p[1] << 8) + (p[2] << 16) + (p[3] << 24);
+#endif
+ return value;
+}
+
+
+/* Convert 16-bit value VALUE which is in little-endian byte-order
+ to host byte-order. */
+
+static u_int16_t
+le2hs (value)
+ u_int16_t value;
+{
+#ifdef WORDS_BIG_ENDIAN
+ unsigned char *p = (unsigned char *) &value;
+ value = p[0] + (p[1] << 8);
+#endif
+ return value;
+}
+
+
+/* Convert 32-bit value VALUE which is in big-endian byte-order
+ to host byte-order. */
+
+static u_int32_t
+be2hl (value)
+ u_int32_t value;
+{
+#ifndef WORDS_BIG_ENDIAN
+ unsigned char *p = (unsigned char *) &value;
+ value = p[3] + (p[2] << 8) + (p[1] << 16) + (p[0] << 24);
+#endif
+ return value;
+}
+
+
+/* Convert 16-bit value VALUE which is in big-endian byte-order
+ to host byte-order. */
+
+static u_int16_t
+be2hs (value)
+ u_int16_t value;
+{
+#ifndef WORDS_BIG_ENDIAN
+ unsigned char *p = (unsigned char *) &value;
+ value = p[1] + (p[0] << 8);
+#endif
+ return value;
+}
+
+
+\f
+/***********************************************************************
+ RIFF-WAVE (*.wav)
+ ***********************************************************************/
+
+/* Try to initialize sound file SF from SF->header. SF->header
+ contains the first MAX_SOUND_HEADER_BYTES number of bytes from the
+ sound file. If the file is a WAV-format file, set up interface
+ functions in SF and convert header fields to host byte-order.
+ Value is non-zero if the file is a WAV file. */
+
+static int
+wav_init (sf)
+ struct sound_file *sf;
+{
+ struct wav_header *header = (struct wav_header *) sf->header;
+
+ if (bcmp (sf->header, "RIFF", 4) != 0)
+ return 0;
+
+ /* WAV files are in little-endian order. Convert the header
+ if on a big-endian machine. */
+ header->magic = le2hl (header->magic);
+ header->length = le2hl (header->length);
+ header->chunk_type = le2hl (header->chunk_type);
+ header->chunk_format = le2hl (header->chunk_format);
+ header->chunk_length = le2hl (header->chunk_length);
+ header->format = le2hs (header->format);
+ header->channels = le2hs (header->channels);
+ header->sample_rate = le2hl (header->sample_rate);
+ header->bytes_per_second = le2hl (header->bytes_per_second);
+ header->sample_size = le2hs (header->sample_size);
+ header->precision = le2hs (header->precision);
+ header->chunk_data = le2hl (header->chunk_data);
+ header->data_length = le2hl (header->data_length);
+
+ /* Set up the interface functions for WAV. */
+ sf->type = RIFF;
+ sf->play = wav_play;
+
+ return 1;
+}
+
+
+/* Play RIFF-WAVE audio file SF on sound device SD. */
+
+static void
+wav_play (sf, sd)
+ struct sound_file *sf;
+ struct sound_device *sd;
+{
+ struct wav_header *header = (struct wav_header *) sf->header;
+ char *buffer;
+ int nbytes;
+ int blksize = 2048;
+
+ /* Let the device choose a suitable device-dependent format
+ for the file. */
+ sd->choose_format (sd, sf);
+
+ /* Configure the device. */
+ sd->sample_size = header->sample_size;
+ sd->sample_rate = header->sample_rate;
+ sd->bps = header->bytes_per_second;
+ sd->channels = header->channels;
+ sd->configure (sd);
+
+ /* Copy sound data to the device. The WAV file specification is
+ actually more complex. This simple scheme worked with all WAV
+ files I found so far. If someone feels inclined to implement the
+ whole RIFF-WAVE spec, please do. */
+ buffer = (char *) alloca (blksize);
+ lseek (sf->fd, sizeof *header, SEEK_SET);
+
+ while ((nbytes = read (sf->fd, buffer, blksize)) > 0)
+ sd->write (sd, buffer, nbytes);
+
+ if (nbytes < 0)
+ sound_perror ("Reading sound file");
+}
+
+
+\f
+/***********************************************************************
+ Sun Audio (*.au)
+ ***********************************************************************/
+
+/* Sun audio file encodings. */
+
+enum au_encoding
+{
+ AU_ENCODING_ULAW_8 = 1,
+ AU_ENCODING_8,
+ AU_ENCODING_16,
+ AU_ENCODING_24,
+ AU_ENCODING_32,
+ AU_ENCODING_IEEE32,
+ AU_ENCODING_IEEE64,
+ AU_COMPRESSED = 23
+};
+
+
+/* Try to initialize sound file SF from SF->header. SF->header
+ contains the first MAX_SOUND_HEADER_BYTES number of bytes from the
+ sound file. If the file is a AU-format file, set up interface
+ functions in SF and convert header fields to host byte-order.
+ Value is non-zero if the file is an AU file. */
+
+static int
+au_init (sf)
+ struct sound_file *sf;
+{
+ struct au_header *header = (struct au_header *) sf->header;
+
+ if (bcmp (sf->header, ".snd", 4) != 0)
+ return 0;
+
+ header->magic_number = be2hl (header->magic_number);
+ header->data_offset = be2hl (header->data_offset);
+ header->data_size = be2hl (header->data_size);
+ header->encoding = be2hl (header->encoding);
+ header->sample_rate = be2hl (header->sample_rate);
+ header->channels = be2hl (header->channels);
+
+ /* Set up the interface functions for AU. */
+ sf->type = SUN_AUDIO;
+ sf->play = au_play;
+
+ return 1;
+}
+
+
+/* Play Sun audio file SF on sound device SD. */
+
+static void
+au_play (sf, sd)
+ struct sound_file *sf;
+ struct sound_device *sd;
+{
+ struct au_header *header = (struct au_header *) sf->header;
+ int blksize = 2048;
+ char *buffer;
+ int nbytes;
+
+ sd->sample_size = 0;
+ sd->sample_rate = header->sample_rate;
+ sd->bps = 0;
+ sd->channels = header->channels;
+ sd->choose_format (sd, sf);
+ sd->configure (sd);
+
+ /* Seek */
+ lseek (sf->fd, header->data_offset, SEEK_SET);
+
+ /* Copy sound data to the device. */
+ buffer = (char *) alloca (blksize);
+ while ((nbytes = read (sf->fd, buffer, blksize)) > 0)
+ sd->write (sd, buffer, nbytes);
+
+ if (nbytes < 0)
+ sound_perror ("Reading sound file");
+}
+
+
+\f
+/***********************************************************************
+ Voxware Driver Interface
+ ***********************************************************************/
+
+/* This driver is available on GNU/Linux, and the free BSDs. FreeBSD
+ has a compatible own driver aka Luigi's driver. */
+
+
+/* Open device SD. If SD->file is non-null, open that device,
+ otherwise use a default device name. */
+
+static void
+vox_open (sd)
+ struct sound_device *sd;
+{
+ char *file;
+
+ /* Open the sound device. Default is /dev/dsp. */
+ if (sd->file)
+ file = sd->file;
+ else
+ file = "/dev/dsp";
+
+ sd->fd = open (file, O_WRONLY);
+ if (sd->fd < 0)
+ sound_perror (file);
+}
+
+
+/* Configure device SD from parameters in it. */
+
+static void
+vox_configure (sd)
+ struct sound_device *sd;
+{
+ int requested;
+
+ xassert (sd->fd >= 0);
+
+ /* Device parameters apparently depend on each other in undocumented
+ ways (not to imply that there is any real documentation). Be
+ careful when reordering the calls below. */
+ if (sd->sample_size > 0
+ && ioctl (sd->fd, SNDCTL_DSP_SAMPLESIZE, &sd->sample_size) < 0)
+ sound_perror ("Setting sample size");
+
+ if (sd->bps > 0
+ && ioctl (sd->fd, SNDCTL_DSP_SPEED, &sd->bps) < 0)
+ sound_perror ("Setting speed");
+
+ if (sd->sample_rate > 0
+ && ioctl (sd->fd, SOUND_PCM_WRITE_RATE, &sd->sample_rate) < 0)
+ sound_perror ("Setting sample rate");
+
+ requested = sd->format;
+ if (ioctl (sd->fd, SNDCTL_DSP_SETFMT, &sd->format) < 0)
+ sound_perror ("Setting format");
+ else if (requested != sd->format)
+ error ("Setting format");
+
+ if (sd->channels > 1
+ && ioctl (sd->fd, SNDCTL_DSP_STEREO, &sd->channels) < 0)
+ sound_perror ("Setting channels");
+
+ if (sd->volume > 0
+ && ioctl (sd->fd, SOUND_MIXER_WRITE_PCM, &sd->volume) < 0)
+ sound_perror ("Setting volume");
+}
+
+
+/* Close device SD if it is open. */
+
+static void
+vox_close (sd)
+ struct sound_device *sd;
+{
+ if (sd->fd >= 0)
+ {
+ /* Flush sound data, and reset the device. */
+ ioctl (sd->fd, SNDCTL_DSP_SYNC, NULL);
+ ioctl (sd->fd, SNDCTL_DSP_RESET, NULL);
+
+ /* Close the device. */
+ close (sd->fd);
+ sd->fd = -1;
+ }
+}
+
+
+/* Choose device-dependent format for device SD from sound file SF. */
+
+static void
+vox_choose_format (sd, sf)
+ struct sound_device *sd;
+ struct sound_file *sf;
+{
+ if (sf->type == RIFF)
+ {
+ struct wav_header *h = (struct wav_header *) sf->header;
+ if (h->precision == 8)
+ sd->format = AFMT_U8;
+ else if (h->precision == 16)
+ sd->format = AFMT_S16_LE;
+ else
+ error ("Unsupported WAV file format");
+ }
+ else if (sf->type == SUN_AUDIO)
+ {
+ struct au_header *header = (struct au_header *) sf->header;
+ switch (header->encoding)
+ {
+ case AU_ENCODING_ULAW_8:
+ case AU_ENCODING_IEEE32:
+ case AU_ENCODING_IEEE64:
+ sd->format = AFMT_MU_LAW;
+ break;
+
+ case AU_ENCODING_8:
+ case AU_ENCODING_16:
+ case AU_ENCODING_24:
+ case AU_ENCODING_32:
+ sd->format = AFMT_S16_LE;
+ break;
+
+ default:
+ error ("Unsupported AU file format");
+ }
+ }
+ else
+ abort ();
+}
+
+
+/* Initialize device SD. Set up the interface functions in the device
+ structure. */
+
+static void
+vox_init (sd)
+ struct sound_device *sd;
+{
+ sd->fd = -1;
+ sd->open = vox_open;
+ sd->close = vox_close;
+ sd->configure = vox_configure;
+ sd->choose_format = vox_choose_format;
+ sd->write = vox_write;
+}
+
+
+/* Write NBYTES bytes from BUFFER to device SD. */
+
+static void
+vox_write (sd, buffer, nbytes)
+ struct sound_device *sd;
+ char *buffer;
+ int nbytes;
+{
+ int nwritten = write (sd->fd, buffer, nbytes);
+ if (nwritten < 0)
+ sound_perror ("Writing to sound device");
+}
+
+
+\f
+/***********************************************************************
+ Initialization
+ ***********************************************************************/
+
+void
+syms_of_sound ()
+{
+ QCdevice = intern (":device");
+ staticpro (&QCdevice);
+ QCvolume = intern (":volume");
+ staticpro (&QCvolume);
+ Qsound = intern ("sound");
+ staticpro (&Qsound);
+ Qplay_sound_hook = intern ("play-sound-hook");
+ staticpro (&Qplay_sound_hook);
+
+ defsubr (&Splay_sound);
+}
+
+
+void
+init_sound ()
+{
+}
+
+#endif /* HAVE_SOUND */
HCoop / bpt / emacs.git / commitdiff