New file.

5 files changed, 2110 insertions, 0 deletions

diff --git a/lisp/gs.el b/lisp/gs.el
new file mode 100644
index 00000000000..2a368bae199
--- /dev/null
+++ b/lisp/gs.el
@@ -0,0 +1,185 @@
+;;; 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.
diff --git a/lisp/image.el b/lisp/image.el
new file mode 100644
index 00000000000..800196ddc65
--- /dev/null
+++ b/lisp/image.el
@@ -0,0 +1,192 @@
+;;; 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.
+
+
+
+
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
new file mode 100644
index 00000000000..ffc4b1be3bc
--- /dev/null
+++ b/lisp/jit-lock.el
@@ -0,0 +1,433 @@
+;;; 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))))
+  
+
+
+;;; 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)
+
+
+
+;;; 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.")
+
+
+
+;;; 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))
+
+
+
+;;; 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))))
+
+
+
+;;; 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))))))))))))
+
+
+
+;;; 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
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
new file mode 100644
index 00000000000..ab21bf13dfd
--- /dev/null
+++ b/lisp/tooltip.el
@@ -0,0 +1,476 @@
+;;; 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)
+
+
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl)
+  (require 'comint)
+  (require 'gud))
+
+(provide 'tooltip)
+
+
+;;; 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)
+
+
+
+;;; 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.")
+
+
+
+;;; 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))))
+
+
+
+;;; 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))))))
+
+
+
+;;; 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))
+
+
+
+;;; 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)))
+
+
+
+;;; 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))))
+
+
+
+;;; 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))
+
+
+
+;;; 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)))))
+
+
+
+;;; 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))
+
+
+
+;;; 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
diff --git a/src/sound.c b/src/sound.c
new file mode 100644
index 00000000000..51ebc70218a
--- /dev/null
+++ b/src/sound.c
@@ -0,0 +1,824 @@
+/* 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 *));
+
+
+
+/***********************************************************************
+                               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;
+}
+
+
+/***********************************************************************
+                        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;
+}
+
+
+
+/***********************************************************************
+                          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");
+}
+
+
+
+/***********************************************************************
+                           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");
+}
+
+
+
+/***********************************************************************
+                       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");
+}
+
+
+
+/***********************************************************************
+                            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 */