diff options
| -rw-r--r-- | lisp/emacs-lisp/autoload.el | 290 | ||||
| -rw-r--r-- | lisp/emacs-lisp/debug.el | 347 | ||||
| -rw-r--r-- | lisp/play/blackbox.el | 420 | ||||
| -rw-r--r-- | lisp/progmodes/asm-mode.el | 210 |
4 files changed, 1267 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el new file mode 100644 index 00000000000..0a7c9dc74c7 --- /dev/null +++ b/lisp/emacs-lisp/autoload.el @@ -0,0 +1,290 @@ +;;; 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) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el new file mode 100644 index 00000000000..1b4ebf8c3b9 --- /dev/null +++ b/lisp/emacs-lisp/debug.el @@ -0,0 +1,347 @@ +;; 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)) + +(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))) + +(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)) + +;;;###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.")))) diff --git a/lisp/play/blackbox.el b/lisp/play/blackbox.el new file mode 100644 index 00000000000..35be83f2db5 --- /dev/null +++ b/lisp/play/blackbox.el @@ -0,0 +1,420 @@ +; 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)))))) diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el new file mode 100644 index 00000000000..6ef6e5ff83a --- /dev/null +++ b/lisp/progmodes/asm-mode.el @@ -0,0 +1,210 @@ +;; 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) + ) + + +(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 |