From 7840ced19916e4443b30d00c386b6b3d8584459e Mon Sep 17 00:00:00 2001 From: Gerd Moellmann Date: Wed, 21 Jul 1999 21:43:52 +0000 Subject: [PATCH] New file. --- lisp/gs.el | 185 +++++++++++ lisp/image.el | 192 +++++++++++ lisp/jit-lock.el | 433 +++++++++++++++++++++++++ lisp/tooltip.el | 476 +++++++++++++++++++++++++++ src/sound.c | 824 +++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 2110 insertions(+) create mode 100644 lisp/gs.el create mode 100644 lisp/image.el create mode 100644 lisp/jit-lock.el create mode 100644 lisp/tooltip.el create mode 100644 src/sound.c diff --git a/lisp/gs.el b/lisp/gs.el new file mode 100644 index 0000000000..2a368bae19 --- /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=" + "") + "List of command line arguments to pass to Ghostscript. +Arguments may contain place-holders `' for the name of the +input file, and `' 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 `', +FILE is the value to substitute for the place-holder `'." + (mapcar #'(lambda (option) + (setq option (gs-replace-in-string option "" device) + option (gs-replace-in-string option "" 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 0000000000..800196ddc6 --- /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 0000000000..ffc4b1be3b --- /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 +;; 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 0000000000..ab21bf13df --- /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 +;; 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 0000000000..51ebc70218 --- /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 . Tested with Luigi's + driver on FreeBSD 2.2.7 with a SoundBlaster 16. */ + +#include + +#if defined HAVE_SOUND + +#include +#include +#include +#include +#include +#include + +/* 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 +#endif +#ifdef HAVE_SYS_SOUNDCARD_H +#include +#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 */ -- 2.20.1