--- /dev/null
+;;; Maintain autoloads in loaddefs.el.
+;;; Copyright (C) 1991 Free Software Foundation, Inc.
+;;; Written by Roland McGrath.
+;;;
+;;; This program 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 1, or (at your option)
+;;; any later version.
+;;;
+;;; This program 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.
+;;;
+;;; A copy of the GNU General Public License can be obtained from this
+;;; program's author (send electronic mail to roland@ai.mit.edu) or from
+;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
+;;; 02139, USA.
+;;;
+
+(defun make-autoload (form file)
+ "Turn FORM, a defun or defmacro, into an autoload for source file FILE.
+Returns nil if FORM is not a defun or defmacro."
+ (let ((car (car-safe form)))
+ (if (or (eq car 'defun) (eq car 'defmacro))
+ (let (name doc macrop)
+ (setq macrop (eq car 'defmacro))
+ (setq form (cdr form))
+ (setq name (car form))
+ ;; Ignore the arguments.
+ (setq form (cdr (cdr form)))
+ (setq doc (car form))
+ (if (stringp doc)
+ (setq form (cdr form))
+ (setq doc nil))
+ (list 'autoload (list 'quote name) file doc
+ (eq (car-safe (car form)) 'interactive) macrop))
+ nil)))
+
+(defconst generate-autoload-cookie ";;;###autoload"
+ "Magic comment that tells \\[update-file-autoloads]
+to make the following form into an autoload. This string should be
+meaningless to Lisp (e.g., a comment).
+
+This string is used:
+
+;;;###autoload
+\(defun function-to-be-autoloaded () ...)
+
+If this string appears alone on a line, the following form will be
+read and an autoload made for it. If there is further text on the line,
+that text will be copied verbatim to `generated-autoload-file'.")
+
+(defconst generate-autoload-section-header "\f\n;;;### "
+ "String inserted before the form identifying
+the section of autoloads for a file.")
+
+(defconst generate-autoload-section-trailer "\n;;;***\n"
+ "String which indicates the end of the section of autoloads for a file.")
+
+;; Forms which have doc-strings which should be printed specially.
+;; A doc-string-elt property of ELT says that (nth ELT FORM) is
+;; the doc-string in FORM.
+;; Note: defconst and defvar should NOT be marked in this way.
+;; We don't want to produce defconsts and defvars that make-docfile can
+;; grok, because then it would grok them twice, once in foo.el (where they
+;; are given with ;;;###autoload) and once in loaddefs.el.
+(put 'autoload 'doc-string-elt 3)
+
+(defun generate-file-autoloads (file)
+ "Insert at point a loaddefs autoload section for FILE.
+autoloads are generated for defuns and defmacros in FILE
+marked by `generate-autoload-regexp' (which see).
+If FILE is being visited in a buffer, the contents of the buffer
+are used."
+ (interactive "fGenerate autoloads for file: ")
+ (let ((outbuf (current-buffer))
+ (inbuf (find-file-noselect file))
+ (autoloads-done '())
+ (load-name (let ((name (file-name-nondirectory file)))
+ (if (string-match "\\.elc?$" name)
+ (substring name 0 (match-beginning 0))
+ name)))
+ (print-length nil)
+ (floating-output-format "%20e")
+ (done-any nil)
+ output-end)
+ (message "Generating autoloads for %s..." file)
+ (save-excursion
+ (set-buffer inbuf)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n\f")
+ (cond ((looking-at (regexp-quote generate-autoload-cookie))
+ (search-forward generate-autoload-cookie)
+ (skip-chars-forward " \t")
+ (setq done-any t)
+ (if (eolp)
+ ;; Read the next form and make an autoload.
+ (let* ((form (prog1 (read (current-buffer))
+ (forward-line 1)))
+ (autoload (make-autoload form load-name))
+ (doc-string-elt (get (car-safe form)
+ 'doc-string-elt)))
+ (if autoload
+ (setq autoloads-done (cons (nth 1 form)
+ autoloads-done))
+ (setq autoload form))
+ (if (and doc-string-elt
+ (stringp (nth doc-string-elt autoload)))
+ ;; We need to hack the printing because the
+ ;; doc-string must be printed specially for
+ ;; make-docfile (sigh).
+ (let* ((p (nthcdr (1- doc-string-elt) autoload))
+ (elt (cdr p)))
+ (setcdr p nil)
+ (princ "\n(" outbuf)
+ (mapcar (function (lambda (elt)
+ (prin1 elt outbuf)
+ (princ " " outbuf)))
+ autoload)
+ (princ "\"\\\n" outbuf)
+ (princ (substring (prin1-to-string (car elt)) 1)
+ outbuf)
+ (if (null (cdr elt))
+ (princ ")" outbuf)
+ (princ " " outbuf)
+ (princ (substring (prin1-to-string (cdr elt))
+ 1)
+ outbuf))
+ (terpri outbuf))
+ (print autoload outbuf)))
+ ;; Copy the rest of the line to the output.
+ (let ((begin (point)))
+ (forward-line 1)
+ (princ (buffer-substring begin (point)) outbuf))))
+ ((looking-at ";")
+ ;; Don't read the comment.
+ (forward-line 1))
+ (t
+ (forward-sexp 1)
+ (forward-line 1))))))
+ (set-buffer outbuf)
+ (setq output-end (point-marker)))
+ (if done-any
+ (progn
+ (insert generate-autoload-section-header)
+ (prin1 (list 'autoloads autoloads-done load-name file
+ (nth 5 (file-attributes file)))
+ outbuf)
+ (terpri outbuf)
+ (insert ";;; Generated autoloads from " file "\n")
+ (goto-char output-end)
+ (insert generate-autoload-section-trailer)))
+ (message "Generating autoloads for %s...done" file)))
+
+(defconst generated-autoload-file "loaddefs.el"
+ "*File \\[update-file-autoloads] puts autoloads into.
+A .el file can set this in its local variables section to make its
+autoloads go somewhere else.")
+
+;;;###autoload
+(defun update-file-autoloads (file)
+ "Update the autoloads for FILE in `generated-autoload-file'
+\(which FILE might bind in its local variables)."
+ (interactive "fUpdate autoloads for file: ")
+ (let ((load-name (let ((name (file-name-nondirectory file)))
+ (if (string-match "\\.elc?$" name)
+ (substring name 0 (match-beginning 0))
+ name)))
+ (done nil)
+ (existing-buffer (get-file-buffer file)))
+ (save-excursion
+ ;; We want to get a value for generated-autoload-file from
+ ;; the local variables section if it's there.
+ (set-buffer (find-file-noselect file))
+ (set-buffer (find-file-noselect generated-autoload-file))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (search-forward generate-autoload-section-header nil t)
+ (let ((form (condition-case ()
+ (read (current-buffer))
+ (end-of-file nil))))
+ (if (string= (nth 2 form) load-name)
+ (let ((begin (match-beginning 0))
+ (last-time (nth 4 form))
+ (file-time (nth 5 (file-attributes file))))
+ (if (and (or (null existing-buffer)
+ (not (buffer-modified-p existing-buffer)))
+ (listp last-time) (= (length last-time) 2)
+ (or (> (car last-time) (car file-time))
+ (and (= (car last-time) (car file-time))
+ (>= (nth 1 last-time)
+ (nth 1 file-time)))))
+ (message "Autoload section for %s is up to date."
+ file)
+ (search-forward generate-autoload-section-trailer)
+ (delete-region begin (point))
+ (generate-file-autoloads file))
+ (setq done t))))))
+ (if done
+ ()
+ ;; Have the user tell us where to put the section.
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ (with-output-to-temp-buffer "*Help*"
+ (princ (substitute-command-keys
+ (format "\
+Move point to where the autoload section
+for %s should be inserted.
+Then do \\[exit-recursive-edit]."
+ file))))
+ (recursive-edit))
+ (generate-file-autoloads file)))
+ (if (and (null existing-buffer)
+ (setq existing-buffer (get-file-buffer file)))
+ (kill-buffer existing-buffer)))))
+
+;;;###autoload
+(defun update-autoloads-here ()
+ "Update the sections of the current buffer generated by
+\\[update-file-autoloads]."
+ (interactive)
+ (let ((generated-autoload-file (buffer-file-name)))
+ (save-excursion
+ (goto-char (point-min))
+ (while (search-forward generate-autoload-section-header nil t)
+ (let* ((form (condition-case ()
+ (read (current-buffer))
+ (end-of-file nil)))
+ (file (nth 3 form)))
+ (if (and (stringp file)
+ (or (get-file-buffer file)
+ (file-exists-p file)))
+ ()
+ (setq file (if (y-or-n-p (format "Library \"%s\" (load \
+file \"%s\") doesn't exist. Remove its autoload section? "
+ (nth 2 form) file))
+ t
+ (condition-case ()
+ (read-file-name (format "Find \"%s\" load file: "
+ (nth 2 form))
+ nil nil t)
+ (quit nil)))))
+ (if file
+ (let ((begin (match-beginning 0)))
+ (search-forward generate-autoload-section-trailer)
+ (delete-region begin (point))))
+ (if (stringp file)
+ (generate-file-autoloads file)))))))
+
+;;;###autoload
+(defun update-directory-autoloads (dir)
+ "Run \\[update-file-autoloads] on each .el file in DIR."
+ (interactive "DUpdate autoloads for directory: ")
+ (mapcar 'update-file-autoloads
+ (directory-files dir nil "\\.el$")))
+
+;;;###autoload
+(defun batch-update-autoloads ()
+ "Update the autoloads for the files or directories on the command line.
+Runs \\[update-file-autoloads] on files and \\[update-directory-autoloads]
+on directories. Must be used only with -batch, and kills Emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-byte-compile *.el\""
+ (if (not noninteractive)
+ (error "batch-update-file-autoloads is to be used only with -batch"))
+ (let ((lost nil)
+ (args command-line-args-left))
+ (while args
+ (catch 'file
+ (condition-case lossage
+ (if (file-directory-p (expand-file-name (car args)))
+ (update-directory-autoloads (car args))
+ (update-file-autoloads (car args)))
+ (error (progn (message ">>Error processing %s: %s"
+ (car args) lossage)
+ (setq lost t)
+ (throw 'file nil)))))
+ (setq args (cdr args)))
+ (save-some-buffers t)
+ (message "Done")
+ (kill-emacs (if lost 1 0))))
+
+(provide 'autoload)
--- /dev/null
+;; Debuggers and related commands for Emacs
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar debug-function-list nil
+ "List of functions currently set for debug on entry.")
+
+;;;###autoload
+(setq debugger 'debug)
+;;;###autoload
+(defun debug (&rest debugger-args)
+ "Enter debugger. Returns if user says \"continue\".
+Arguments are mainly for use when this is called from the internals
+of the evaluator.
+
+You may call with no args, or you may pass nil as the first arg and
+any other args you like. In that case, the list of args after the
+first will be printed into the backtrace buffer."
+ (message "Entering debugger...")
+ (let (debugger-value
+ (debugger-match-data (match-data))
+ (debug-on-error nil)
+ (debug-on-quit nil)
+ (debugger-buffer (let ((default-major-mode 'fundamental-mode))
+ (generate-new-buffer "*Backtrace*")))
+ (debugger-old-buffer (current-buffer))
+ (debugger-step-after-exit nil)
+ ;; Don't keep reading from an executing kbd macro!
+ (executing-macro nil)
+ (cursor-in-echo-area nil))
+ (unwind-protect
+ (save-excursion
+ (save-window-excursion
+ (pop-to-buffer debugger-buffer)
+ (erase-buffer)
+ (let ((standard-output (current-buffer))
+ (print-escape-newlines t)
+ (print-length 50))
+ (backtrace))
+ (goto-char (point-min))
+ (debugger-mode)
+ (delete-region (point)
+ (progn
+ (search-forward "\n debug(")
+ (forward-line 1)
+ (point)))
+ (debugger-reenable)
+ (cond ((memq (car debugger-args) '(lambda debug))
+ (insert "Entering:\n")
+ (if (eq (car debugger-args) 'debug)
+ (progn
+ (backtrace-debug 4 t)
+ (delete-char 1)
+ (insert ?*)
+ (beginning-of-line))))
+ ((eq (car debugger-args) 'exit)
+ (insert "Return value: ")
+ (setq debugger-value (nth 1 debugger-args))
+ (prin1 debugger-value (current-buffer))
+ (insert ?\n)
+ (delete-char 1)
+ (insert ? )
+ (beginning-of-line))
+ ((eq (car debugger-args) 'error)
+ (insert "Signalling: ")
+ (prin1 (nth 1 debugger-args) (current-buffer))
+ (insert ?\n))
+ ((eq (car debugger-args) t)
+ (insert "Beginning evaluation of function call form:\n"))
+ (t
+ (prin1 (if (eq (car debugger-args) 'nil)
+ (cdr debugger-args) debugger-args)
+ (current-buffer))
+ (insert ?\n)))
+ (message "")
+ (let ((inhibit-trace t)
+ (standard-output nil)
+ (buffer-read-only t))
+ (message "")
+ (recursive-edit))))
+ ;; So that users do not try to execute debugger commands
+ ;; in an invalid context
+ (kill-buffer debugger-buffer)
+ (store-match-data debugger-match-data))
+ (setq debug-on-next-call debugger-step-after-exit)
+ debugger-value))
+\f
+(defun debugger-step-through ()
+ "Proceed, stepping through subexpressions of this expression.
+Enter another debugger on next entry to eval, apply or funcall."
+ (interactive)
+ (setq debugger-step-after-exit t)
+ (message "Proceeding, will debug on next eval or call.")
+ (exit-recursive-edit))
+
+(defun debugger-continue ()
+ "Continue, evaluating this expression without stopping."
+ (interactive)
+ (message "Continuing.")
+ (exit-recursive-edit))
+
+(defun debugger-return-value (val)
+ "Continue, specifying value to return.
+This is only useful when the value returned from the debugger
+will be used, such as in a debug on exit from a frame."
+ (interactive "XReturn value (evaluated): ")
+ (setq debugger-value val)
+ (princ "Returning " t)
+ (prin1 debugger-value)
+ (exit-recursive-edit))
+
+(defun debugger-jump ()
+ "Continue to exit from this frame, with all debug-on-entry suspended."
+ (interactive)
+ ;; Compensate for the two extra stack frames for debugger-jump.
+ (let ((debugger-frame-offset (+ debugger-frame-offset 2)))
+ (debugger-frame))
+ ;; Turn off all debug-on-entry functions
+ ;; but leave them in the list.
+ (let ((list debug-function-list))
+ (while list
+ (fset (car list)
+ (debug-on-entry-1 (car list) (symbol-function (car list)) nil))
+ (setq list (cdr list))))
+ (message "Continuing through this frame")
+ (exit-recursive-edit))
+
+(defun debugger-reenable ()
+ "Turn all debug-on-entry functions back on."
+ (let ((list debug-function-list))
+ (while list
+ (or (consp (symbol-function (car list)))
+ (debug-convert-byte-code (car list)))
+ (fset (car list)
+ (debug-on-entry-1 (car list) (symbol-function (car list)) t))
+ (setq list (cdr list)))))
+
+(defun debugger-frame-number ()
+ "Return number of frames in backtrace before the one point points at."
+ (save-excursion
+ (beginning-of-line)
+ (let ((opoint (point))
+ (count 0))
+ (goto-char (point-min))
+ (if (or (equal (buffer-substring (point) (+ (point) 6))
+ "Signal")
+ (equal (buffer-substring (point) (+ (point) 6))
+ "Return"))
+ (progn
+ (search-forward ":")
+ (forward-sexp 1)))
+ (forward-line 1)
+ (while (progn
+ (forward-char 2)
+ (if (= (following-char) ?\()
+ (forward-sexp 1)
+ (forward-sexp 2))
+ (forward-line 1)
+ (<= (point) opoint))
+ (setq count (1+ count)))
+ count)))
+
+;; Chosen empirically to account for all the frames
+;; that will exist when debugger-frame is called
+;; within the first one that appears in the backtrace buffer.
+;; Assumes debugger-frame is called from a key;
+;; will be wrong if it is called with Meta-x.
+(defconst debugger-frame-offset 8 "")
+
+(defun debugger-frame ()
+ "Request entry to debugger when this frame exits.
+Applies to the frame whose line point is on in the backtrace."
+ (interactive)
+ (beginning-of-line)
+ (let ((level (debugger-frame-number)))
+ (backtrace-debug (+ level debugger-frame-offset) t))
+ (if (= (following-char) ? )
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert ?*)))
+ (beginning-of-line))
+
+(defun debugger-frame-clear ()
+ "Do not enter to debugger when this frame exits.
+Applies to the frame whose line point is on in the backtrace."
+ (interactive)
+ (beginning-of-line)
+ (let ((level (debugger-frame-number)))
+ (backtrace-debug (+ level debugger-frame-offset) nil))
+ (if (= (following-char) ?*)
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert ? )))
+ (beginning-of-line))
+
+(defun debugger-eval-expression (exp)
+ (interactive "xEval: ")
+ (save-excursion
+ (if (null (buffer-name debugger-old-buffer))
+ ;; old buffer deleted
+ (setq debugger-old-buffer (current-buffer)))
+ (set-buffer debugger-old-buffer)
+ (eval-expression exp)))
+\f
+(defvar debugger-mode-map nil)
+(if debugger-mode-map
+ nil
+ (let ((loop ? ))
+ (setq debugger-mode-map (make-keymap))
+ (suppress-keymap debugger-mode-map)
+ (define-key debugger-mode-map "-" 'negative-argument)
+ (define-key debugger-mode-map "b" 'debugger-frame)
+ (define-key debugger-mode-map "c" 'debugger-continue)
+ (define-key debugger-mode-map "j" 'debugger-jump)
+ (define-key debugger-mode-map "r" 'debugger-return-value)
+ (define-key debugger-mode-map "u" 'debugger-frame-clear)
+ (define-key debugger-mode-map "d" 'debugger-step-through)
+ (define-key debugger-mode-map "l" 'debugger-list-functions)
+ (define-key debugger-mode-map "h" 'describe-mode)
+ (define-key debugger-mode-map "q" 'top-level)
+ (define-key debugger-mode-map "e" 'debugger-eval-expression)
+ (define-key debugger-mode-map " " 'next-line)))
+
+(put 'debugger-mode 'mode-class 'special)
+
+(defun debugger-mode ()
+ "Mode for backtrace buffers, selected in debugger.
+\\<debugger-mode-map>
+A line starts with `*' if exiting that frame will call the debugger.
+Type \\[debugger-frame] or \\[debugger-frame-clear] to set or remove the `*'.
+
+When in debugger due to frame being exited,
+use the \\[debugger-return-value] command to override the value
+being returned from that frame.
+
+Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control
+which functions will enter the debugger when called.
+
+Complete list of commands:
+\\{debugger-mode-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'debugger-mode)
+ (setq mode-name "Debugger")
+ (setq truncate-lines t)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (use-local-map debugger-mode-map))
+\f
+;;;###autoload
+(defun debug-on-entry (function)
+ "Request FUNCTION to invoke debugger each time it is called.
+If the user continues, FUNCTION's execution proceeds.
+Works by modifying the definition of FUNCTION,
+which must be written in Lisp, not predefined.
+Use \\[cancel-debug-on-entry] to cancel the effect of this command.
+Redefining FUNCTION also does that."
+ (interactive "aDebug on entry (to function): ")
+ (debugger-reenable)
+ (if (subrp (symbol-function function))
+ (error "Function %s is a primitive" function))
+ (or (consp (symbol-function function))
+ (debug-convert-byte-code function))
+ (or (consp (symbol-function function))
+ (error "Definition of %s is not a list" function))
+ (fset function (debug-on-entry-1 function (symbol-function function) t))
+ (or (memq function debug-function-list)
+ (setq debug-function-list (cons function debug-function-list)))
+ function)
+
+;;;###autoload
+(defun cancel-debug-on-entry (&optional function)
+ "Undo effect of \\[debug-on-entry] on FUNCTION.
+If argument is nil or an empty string, cancel for all functions."
+ (interactive "aCancel debug on entry (to function): ")
+ (debugger-reenable)
+ (if (and function (not (string= function "")))
+ (progn
+ (fset function
+ (debug-on-entry-1 function (symbol-function function) nil))
+ (setq debug-function-list (delq function debug-function-list))
+ function)
+ (message "Cancelling debug-on-entry for all functions")
+ (mapcar 'cancel-debug-on-entry debug-function-list)))
+
+(defun debug-convert-byte-code (function)
+ (let ((defn (symbol-function function)))
+ (if (not (consp defn))
+ ;; Assume a compiled code object.
+ (let* ((contents (append defn nil))
+ (body
+ (list (list 'byte-code (nth 1 contents)
+ (nth 2 contents) (nth 3 contents)))))
+ (if (nthcdr 5 contents)
+ (setq body (cons (list 'interactive (nth 5 contents)) body)))
+ (if (nth 4 contents)
+ (setq body (cons (nth 4 contents) body)))
+ (fset function (cons 'lambda (cons (car contents) body)))))))
+
+(defun debug-on-entry-1 (function defn flag)
+ (if (subrp defn)
+ (error "%s is a built-in function" function)
+ (if (eq (car defn) 'macro)
+ (debug-on-entry-1 function (cdr defn) flag)
+ (or (eq (car defn) 'lambda)
+ (error "%s not user-defined Lisp function" function))
+ (let (tail prec)
+ (if (stringp (car (nthcdr 2 defn)))
+ (setq tail (nthcdr 3 defn)
+ prec (list (car defn) (car (cdr defn))
+ (car (cdr (cdr defn)))))
+ (setq tail (nthcdr 2 defn)
+ prec (list (car defn) (car (cdr defn)))))
+ (if (eq flag (equal (car tail) '(debug 'debug)))
+ defn
+ (if flag
+ (nconc prec (cons '(debug 'debug) tail))
+ (nconc prec (cdr tail))))))))
+
+(defun debugger-list-functions ()
+ "Display a list of all the functions now set to debug on entry."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (if (null debug-function-list)
+ (princ "No debug-on-entry functions now\n")
+ (princ "Functions set to debug on entry:\n\n")
+ (let ((list debug-function-list))
+ (while list
+ (prin1 (car list))
+ (terpri)
+ (setq list (cdr list))))
+ (princ "Note: if you have redefined a function, then it may no longer\n")
+ (princ "be set to debug on entry, even if it is in the list."))))
--- /dev/null
+; Blackbox game in Emacs Lisp
+;; Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+; by F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu>
+; doc comment by Root Boy Jim <rbj@dsys.icst.nbs.gov>, 27 Apr 89
+; interface improvements by Eric Raymond <eric@snark.thyrsus.com>, Dec 5 1991.
+
+; The object of the game is to find four hidden balls by shooting rays
+; into the black box. There are four possibilities: 1) the ray will
+; pass thru the box undisturbed, 2) it will hit a ball and be absorbed,
+; 3) it will be deflected and exit the box, or 4) be deflected immediately,
+; not even being allowed entry into the box.
+;
+; The strange part is the method of deflection. It seems that rays will
+; not pass next to a ball, and change direction at right angles to avoid it.
+;
+; R 3
+; 1 - - - - - - - - 1
+; - - - - - - - -
+; - O - - - - - - 3
+; 2 - - - - O - O -
+; 4 - - - - - - - -
+; 5 - - - - - - - - 5
+; - - - - - - - - R
+; H - - - - - - - O
+; 2 H 4 H
+;
+; Rays which enter and exit are numbered. You can see that rays 1 & 5 pass
+; thru the box undisturbed. Ray 2 is deflected by the northwesternmost
+; ball. Likewise rays 3 and 4. Rays which hit balls and are absorbed are
+; marked with H. The bottom of the left and the right of the bottom hit
+; the southeastern ball directly. Rays may also hit balls after being
+; reflected. Consider the H on the bottom next to the 4. It bounces off
+; the NW-ern most ball and hits the central ball. A ray shot from above
+; the right side 5 would hit the SE-ern most ball. The R beneath the 5
+; is because the ball is returned instantly. It is not allowed into
+; the box if it would reflect immediately. The R on the top is a more
+; leisurely return. Both central balls would tend to deflect it east
+; or west, but it cannot go either way, so it just retreats.
+;
+; At the end of the game, if you've placed guesses for as many balls as
+; there are in the box, the true board position will be revealed. Each
+; `x' is an incorrect guess of yours; `o' is the true location of a ball.
+
+(defvar blackbox-mode-map nil "")
+
+(if blackbox-mode-map
+ ()
+ (setq blackbox-mode-map (make-keymap))
+ (suppress-keymap blackbox-mode-map t)
+ (define-key blackbox-mode-map "\C-f" 'bb-right)
+ (define-key blackbox-mode-map "\C-b" 'bb-left)
+ (define-key blackbox-mode-map "\C-p" 'bb-up)
+ (define-key blackbox-mode-map "\C-n" 'bb-down)
+ (define-key blackbox-mode-map "\C-e" 'bb-eol)
+ (define-key blackbox-mode-map "\C-a" 'bb-bol)
+ (define-key blackbox-mode-map " " 'bb-romp)
+ (define-key blackbox-mode-map "\C-m" 'bb-done)
+
+ ;; This is a kluge. What we really want is a general
+ ;; feature for reminding terminal keys to the functions
+ ;; corresponding to them in local maps
+ (if (featurep 'keypad)
+ (let (keys)
+ (if (setq keys (function-key-sequence ?u)) ; Up Arrow
+ (define-key blackbox-mode-map keys 'bb-up))
+ (if (setq keys (function-key-sequence ?d)) ; Down Arrow
+ (define-key blackbox-mode-map keys 'bb-down))
+ (if (setq keys (function-key-sequence ?l)) ; Left Arrow
+ (define-key blackbox-mode-map keys 'bb-left))
+ (if (setq keys (function-key-sequence ?r)) ; Right Arrow
+ (define-key blackbox-mode-map keys 'bb-right))
+ (if (setq keys (function-key-sequence ?e)) ; Enter
+ (define-key blackbox-mode-map keys 'bb-done))
+ (if (setq keys (function-key-sequence ?I)) ; Insert
+ (define-key blackbox-mode-map keys 'bb-romp))
+ )))
+
+
+;; Blackbox mode is suitable only for specially formatted data.
+(put 'blackbox-mode 'mode-class 'special)
+
+(defun blackbox-mode ()
+ "Major mode for playing blackbox. To learn how to play blackbox,
+see the documentation for function `blackbox'.
+
+The usual mnemonic keys move the cursor around the box.
+\\<blackbox-mode-map>\\[bb-bol] and \\[bb-eol] move to the beginning and end of line, respectively.
+
+\\[bb-romp] -- send in a ray from point, or toggle a ball at point
+\\[bb-done] -- end game and get score
+"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map blackbox-mode-map)
+ (setq truncate-lines t)
+ (setq major-mode 'blackbox-mode)
+ (setq mode-name "Blackbox"))
+
+(defun blackbox (num)
+ "Play blackbox. Optional prefix argument is the number of balls;
+the default is 4.
+
+What is blackbox?
+
+Blackbox is a game of hide and seek played on an 8 by 8 grid (the
+Blackbox). Your opponent (Emacs, in this case) has hidden several
+balls (usually 4) within this box. By shooting rays into the box and
+observing where they emerge it is possible to deduce the positions of
+the hidden balls. The fewer rays you use to find the balls, the lower
+your score.
+
+Overview of play:
+
+To play blackbox, call the function `blackbox'. An optional prefix
+argument specifies the number of balls to be hidden in the box; the
+default is four.
+
+The cursor can be moved around the box with the standard cursor
+movement keys.
+
+To shoot a ray, move the cursor to the edge of the box and press SPC.
+The result will be determined and the playfield updated.
+
+You may place or remove balls in the box by moving the cursor into the
+box and pressing \\<bb-romp>.
+
+When you think the configuration of balls you have placed is correct,
+press \\<bb-done>. You will be informed whether you are correct or not, and
+be given your score. Your score is the number of letters and numbers
+around the outside of the box plus five for each incorrectly placed
+ball. If you placed any balls incorrectly, they will be indicated
+with `x', and their actual positions indicated with `o'.
+
+Details:
+
+There are three possible outcomes for each ray you send into the box:
+
+ Detour: the ray is deflected and emerges somewhere other than
+ where you sent it in. On the playfield, detours are
+ denoted by matching pairs of numbers -- one where the
+ ray went in, and the other where it came out.
+
+ Reflection: the ray is reflected and emerges in the same place
+ it was sent in. On the playfield, reflections are
+ denoted by the letter `R'.
+
+ Hit: the ray strikes a ball directly and is absorbed. It does
+ not emerge from the box. On the playfield, hits are
+ denoted by the letter `H'.
+
+The rules for how balls deflect rays are simple and are best shown by
+example.
+
+As a ray approaches a ball it is deflected ninety degrees. Rays can
+be deflected multiple times. In the diagrams below, the dashes
+represent empty box locations and the letter `O' represents a ball.
+The entrance and exit points of each ray are marked with numbers as
+described under \"Detour\" above. Note that the entrance and exit
+points are always interchangeable. `*' denotes the path taken by the
+ray.
+
+Note carefully the relative positions of the ball and the ninety
+degree deflection it causes.
+
+ 1
+ - * - - - - - - - - - - - - - - - - - - - - - -
+ - * - - - - - - - - - - - - - - - - - - - - - -
+1 * * - - - - - - - - - - - - - - - O - - - - O -
+ - - O - - - - - - - O - - - - - - - * * * * - -
+ - - - - - - - - - - - * * * * * 2 3 * * * - - * - -
+ - - - - - - - - - - - * - - - - - - - O - * - -
+ - - - - - - - - - - - * - - - - - - - - * * - -
+ - - - - - - - - - - - * - - - - - - - - * - O -
+ 2 3
+
+As mentioned above, a reflection occurs when a ray emerges from the same point
+it was sent in. This can happen in several ways:
+
+
+ - - - - - - - - - - - - - - - - - - - - - - - -
+ - - - - O - - - - - O - O - - - - - - - - - - -
+R * * * * - - - - - - - * - - - - O - - - - - - -
+ - - - - O - - - - - - * - - - - R - - - - - - - -
+ - - - - - - - - - - - * - - - - - - - - - - - -
+ - - - - - - - - - - - * - - - - - - - - - - - -
+ - - - - - - - - R * * * * - - - - - - - - - - - -
+ - - - - - - - - - - - - O - - - - - - - - - - -
+
+In the first example, the ray is deflected downwards by the upper
+ball, then left by the lower ball, and finally retraces its path to
+its point of origin. The second example is similar. The third
+example is a bit anomalous but can be rationalized by realizing the
+ray never gets a chance to get into the box. Alternatively, the ray
+can be thought of as being deflected downwards and immediately
+emerging from the box.
+
+A hit occurs when a ray runs straight into a ball:
+
+ - - - - - - - - - - - - - - - - - - - - - - - -
+ - - - - - - - - - - - - - - - - - - - - O - - -
+ - - - - - - - - - - - - O - - - H * * * * - - - -
+ - - - - - - - - H * * * * O - - - - - - * - - - -
+ - - - - - - - - - - - - O - - - - - - O - - - -
+H * * * O - - - - - - - - - - - - - - - - - - - -
+ - - - - - - - - - - - - - - - - - - - - - - - -
+ - - - - - - - - - - - - - - - - - - - - - - - -
+
+Be sure to compare the second example of a hit with the first example of
+a reflection."
+ (interactive "P")
+ (switch-to-buffer "*Blackbox*")
+ (blackbox-mode)
+ (setq buffer-read-only t)
+ (buffer-disable-undo (current-buffer))
+ (setq bb-board (bb-init-board (or num 4)))
+ (setq bb-balls-placed nil)
+ (setq bb-x -1)
+ (setq bb-y -1)
+ (setq bb-score 0)
+ (setq bb-detour-count 0)
+ (bb-insert-board)
+ (bb-goto (cons bb-x bb-y)))
+
+(defun bb-init-board (num-balls)
+ (random t)
+ (let (board pos)
+ (while (>= (setq num-balls (1- num-balls)) 0)
+ (while
+ (progn
+ (setq pos (cons (random 8) (random 8)))
+ (bb-member pos board)))
+ (setq board (cons pos board)))
+ board))
+
+(defun bb-insert-board ()
+ (let (i (buffer-read-only nil))
+ (erase-buffer)
+ (insert " \n")
+ (setq i 8)
+ (while (>= (setq i (1- i)) 0)
+ (insert " - - - - - - - - \n"))
+ (insert " \n")
+ (insert (format "\nThere are %d balls in the box" (length bb-board)))
+ ))
+
+(defun bb-right ()
+ (interactive)
+ (if (= bb-x 8)
+ ()
+ (forward-char 2)
+ (setq bb-x (1+ bb-x))))
+
+(defun bb-left ()
+ (interactive)
+ (if (= bb-x -1)
+ ()
+ (backward-char 2)
+ (setq bb-x (1- bb-x))))
+
+(defun bb-up ()
+ (interactive)
+ (if (= bb-y -1)
+ ()
+ (previous-line 1)
+ (setq bb-y (1- bb-y))))
+
+(defun bb-down ()
+ (interactive)
+ (if (= bb-y 8)
+ ()
+ (next-line 1)
+ (setq bb-y (1+ bb-y))))
+
+(defun bb-eol ()
+ (interactive)
+ (setq bb-x 8)
+ (bb-goto (cons bb-x bb-y)))
+
+(defun bb-bol ()
+ (interactive)
+ (setq bb-x -1)
+ (bb-goto (cons bb-x bb-y)))
+
+(defun bb-romp ()
+ (interactive)
+ (cond
+ ((and
+ (or (= bb-x -1) (= bb-x 8))
+ (or (= bb-y -1) (= bb-y 8))))
+ ((bb-outside-box bb-x bb-y)
+ (bb-trace-ray bb-x bb-y))
+ (t
+ (bb-place-ball bb-x bb-y))))
+
+(defun bb-place-ball (x y)
+ (let ((coord (cons x y)))
+ (cond
+ ((bb-member coord bb-balls-placed)
+ (setq bb-balls-placed (bb-delete coord bb-balls-placed))
+ (bb-update-board "-"))
+ (t
+ (setq bb-balls-placed (cons coord bb-balls-placed))
+ (bb-update-board "O")))))
+
+(defun bb-trace-ray (x y)
+ (let ((result (bb-trace-ray-2
+ t
+ x
+ (cond
+ ((= x -1) 1)
+ ((= x 8) -1)
+ (t 0))
+ y
+ (cond
+ ((= y -1) 1)
+ ((= y 8) -1)
+ (t 0)))))
+ (cond
+ ((eq result 'hit)
+ (bb-update-board "H")
+ (setq bb-score (1+ bb-score)))
+ ((equal result (cons x y))
+ (bb-update-board "R")
+ (setq bb-score (1+ bb-score)))
+ (t
+ (setq bb-detour-count (1+ bb-detour-count))
+ (bb-update-board (format "%d" bb-detour-count))
+ (save-excursion
+ (bb-goto result)
+ (bb-update-board (format "%d" bb-detour-count)))
+ (setq bb-score (+ bb-score 2))))))
+
+(defun bb-trace-ray-2 (first x dx y dy)
+ (cond
+ ((and (not first)
+ (bb-outside-box x y))
+ (cons x y))
+ ((bb-member (cons (+ x dx) (+ y dy)) bb-board)
+ 'hit)
+ ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)
+ (bb-trace-ray-2 nil x (- dy) y (- dx)))
+ ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
+ (bb-trace-ray-2 nil x dy y dx))
+ (t
+ (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
+
+(defun bb-done ()
+ "Finish the game and report score."
+ (interactive)
+ (let (bogus-balls)
+ (cond
+ ((not (= (length bb-balls-placed) (length bb-board)))
+ (message "There %s %d hidden ball%s; you have placed %d."
+ (if (= (length bb-board) 1) "is" "are")
+ (length bb-board)
+ (if (= (length bb-board) 1) "" "s")
+ (length bb-balls-placed)))
+ (t
+ (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
+ (if (= bogus-balls 0)
+ (message "Right! Your score is %d." bb-score)
+ (message "Oops! You missed %d ball%s. Your score is %d."
+ bogus-balls
+ (if (= bogus-balls 1) "" "s")
+ (+ bb-score (* 5 bogus-balls))))
+ (bb-goto '(-1 . -1))))))
+
+(defun bb-show-bogus-balls (balls-placed board)
+ (bb-show-bogus-balls-2 balls-placed board "x")
+ (bb-show-bogus-balls-2 board balls-placed "o"))
+
+(defun bb-show-bogus-balls-2 (list-1 list-2 c)
+ (cond
+ ((null list-1)
+ 0)
+ ((bb-member (car list-1) list-2)
+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
+ (t
+ (bb-goto (car list-1))
+ (bb-update-board c)
+ (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
+
+;; blackbox.el ends here
+
+(defun bb-goto (pos)
+ (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
+
+(defun bb-update-board (c)
+ (let ((buffer-read-only nil))
+ (backward-char (1- (length c)))
+ (delete-char (length c))
+ (insert c)
+ (backward-char 1)))
+
+(defun bb-member (elt list)
+ "Returns non-nil if ELT is an element of LIST."
+ (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list))))
+
+(defun bb-delete (item list)
+ "Deletes ITEM from LIST and returns a copy."
+ (cond
+ ((equal item (car list)) (cdr list))
+ (t (cons (car list) (bb-delete item (cdr list))))))
--- /dev/null
+;; Mode for editing assembler code
+;; Copyright (C) 1991 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; This mode was written for Eric S. Raymond <eric@snark.thyrsus.com>,
+;; inspired by an earlier asm-mode by Martin Neitzel.
+;; @(#)asm-mode.el 1.1
+
+;; This minor mode is based on text mode. It defines a private abbrev table
+;; that can be used to save abbrevs for assembler mnemonics. It binds just
+;; five keys:
+;;
+;; TAB tab to next tab stop
+;; : outdent preceding label, tab to tab stop
+;; ; place or move comment
+;; C-j, C-m newline and tab to tab stop
+;;
+;; Code is indented to the first tab stop level.
+;; The ; key inserts copies of the value of asm-comment-char at an
+;; appropriate spot.
+;; This mode runs two hooks:
+;; 1) An asm-set-comment-hook before the part of the initialization
+;; depending on asm-comment-char, and
+;; 2) an asm-mode-hook at the end of initialization.
+
+(defvar asm-comment-char ?;
+ "*The comment-start character assumed by asm-mode.")
+
+(defvar asm-mode-syntax-table nil
+ "Syntax table used while in asm mode.")
+
+(defvar asm-mode-abbrev-table nil
+ "Abbrev table used while in asm mode.")
+(define-abbrev-table 'asm-mode-abbrev-table ())
+
+(defvar asm-mode-map nil
+ "Keymap for asm-mode")
+
+(if asm-mode-map
+ nil
+ (setq asm-mode-map (make-sparse-keymap))
+ (define-key asm-mode-map ";" 'asm-comment)
+ (define-key asm-mode-map ":" 'asm-colon)
+ (define-key asm-mode-map "\C-i" 'tab-to-tab-stop)
+ (define-key asm-mode-map "\C-j" 'asm-newline)
+ (define-key asm-mode-map "\C-m" 'asm-newline)
+ )
+
+(defvar asm-code-level-empty-comment-pattern nil)
+(defvar asm-flush-left-empty-comment-pattern nil)
+(defvar asm-inline-empty-comment-pattern nil)
+
+;;;###autoload
+(defun asm-mode ()
+ "Major mode for editing typical assembler code.
+Features a private asm-mode-abbrev-table and the following bindings:
+
+\\[asm-colon]\toutdent a preceding label, tab to next tab stop.
+\\[tab-to-tab-stop]\ttab to next tab stop.
+\\[asm-newline]\tnewline, then tab to next tab stop.
+\\[asm-comment]\tsmart placement of assembler comments.
+
+The character used for making comments is set by the variable
+asm-comment-char (which defaults to ?;). You may want to set this
+appropriately for the assembler on your machine in defaults.el.
+
+Alternatively, you may set this variable in asm-set-comment-hook, which is
+called near the beginning of mode initialization.
+
+Turning on asm-mode calls the value of the variable asm-mode-hook,
+if that value is non-nil, at the end of initialization.
+
+Special commands:\\{asm-mode-map}
+"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map asm-mode-map)
+ (setq mode-name "Assembler")
+ (setq major-mode 'asm-mode)
+ (setq local-abbrev-table asm-mode-abbrev-table)
+ (make-local-variable 'asm-mode-syntax-table)
+ (setq asm-mode-syntax-table (make-syntax-table))
+ (set-syntax-table asm-mode-syntax-table)
+ (run-hooks 'asm-mode-set-comment-hook)
+ (modify-syntax-entry asm-comment-char
+ "<" asm-mode-syntax-table)
+ (modify-syntax-entry ?\n
+ ">" asm-mode-syntax-table)
+ (let ((cs (regexp-quote (char-to-string asm-comment-char))))
+ (make-local-variable 'comment-start)
+ (setq comment-start (concat cs " "))
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip (concat cs "+[ \t]*"))
+ (setq asm-inline-empty-comment-pattern (concat "^.+" cs "+ *$"))
+ (setq asm-code-level-empty-comment-pattern (concat "^[\t ]+" cs cs " *$"))
+ (setq asm-flush-left-empty-comment-pattern (concat "^" cs cs cs " *$"))
+ )
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 32)
+ (auto-fill-mode 1)
+ (setq fill-prefix "\t")
+ (run-hooks 'asm-mode-hook)
+ )
+
+\f
+(defun asm-colon ()
+ "Insert a colon; if it follows a label, delete the label's indentation."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "[ \t]+\\(\\sw\\|\\s_\\)+$")
+ (delete-horizontal-space)))
+ (insert ":")
+ (tab-to-tab-stop)
+ )
+
+(defun asm-newline ()
+ "Insert LFD + fill-prefix, to bring us back to code-indent level."
+ (interactive)
+ (if (eolp) (delete-horizontal-space))
+ (insert "\n")
+ (tab-to-tab-stop)
+ )
+
+(defun asm-line-matches (pattern &optional withcomment)
+ (save-excursion
+ (beginning-of-line)
+ (looking-at pattern)))
+
+(defun asm-pop-comment-level ()
+ ;; Delete an empty comment ending current line. Then set up for a new one,
+ ;; on the current line if it was all comment, otherwise above it
+ (end-of-line)
+ (delete-horizontal-space)
+ (while (= (preceding-char) asm-comment-char)
+ (delete-backward-char 1))
+ (delete-horizontal-space)
+ (if (bolp)
+ nil
+ (beginning-of-line)
+ (open-line 1))
+ )
+
+
+(defun asm-comment ()
+ "Convert an empty comment to a `larger' kind, or start a new one.
+These are the known comment classes:
+
+ 1 -- comment to the right of the code (at the comment-column)
+ 2 -- comment on its own line, indented like code
+ 3 -- comment on its own line, beginning at the left-most column.
+
+Suggested usage: while writing your code, trigger asm-comment
+repeatedly until you are satisfied with the kind of comment."
+ (interactive)
+ (cond
+
+ ;; Blank line? Then start comment at code indent level.
+ ((asm-line-matches "^[ \t]*$")
+ (delete-horizontal-space)
+ (tab-to-tab-stop)
+ (insert asm-comment-char comment-start))
+
+ ;; Nonblank line with no comment chars in it?
+ ;; Then start a comment at the current comment column
+ ((asm-line-matches (format "^[^%c]+$" asm-comment-char))
+ (indent-for-comment))
+
+ ;; Flush-left comment present? Just insert character.
+ ((asm-line-matches asm-flush-left-empty-comment-pattern)
+ (insert asm-comment-char))
+
+ ;; Empty code-level comment already present?
+ ;; Then start flush-left comment, on line above if this one is nonempty.
+ ((asm-line-matches asm-code-level-empty-comment-pattern)
+ (asm-pop-comment-level)
+ (insert asm-comment-char asm-comment-char comment-start))
+
+ ;; Empty comment ends line?
+ ;; Then make code-level comment, on line above if this one is nonempty.
+ ((asm-line-matches asm-inline-empty-comment-pattern)
+ (asm-pop-comment-level)
+ (tab-to-tab-stop)
+ (insert asm-comment-char comment-start))
+
+ ;; If all else fails, insert character
+ (t
+ (insert asm-comment-char))
+
+ )
+ (end-of-line))
+
+;;; asm-mode.el ends here
HCoop / bpt / emacs.git / commitdiff