Add *.info and dir to debbugs

[gnu-emacs-elpa] / packages / lmc / lmc.el

diff --git a/packages/lmc/lmc.el b/packages/lmc/lmc.el
index 1455bd1f329c95080448af3095f79bd26151aad3..b8c8ee028c65041f6c8a09c69db4b19f05785212 100644 (file)
--- a/packages/lmc/lmc.el
+++ b/packages/lmc/lmc.el
@@ -1,8 +1,9 @@
-;;; lmc.el --- Little Man Computer in Elisp
+;;; lmc.el --- Little Man Computer in Elisp  -*- lexical-binding:t -*-

 
 

-;; Copyright (C) 2011  Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2013, 2014  Free Software Foundation, Inc.

 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>

+;; Version: 1.3

 
 ;; 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
 
 ;; 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


@@ -63,6 +64,10 @@
 (eval-when-compile (require 'cl))
 (require 'hexl)
 
 (eval-when-compile (require 'cl))
 (require 'hexl)
 

+(defgroup lmc ()
+  "Customization group for the Little Man Computer simulator."
+  :group 'languages)
+

 ;;; The LMC-Simulator
 
 (defvar lmc--pc 0 "Program counter for LMC.")
 ;;; The LMC-Simulator
 
 (defvar lmc--pc 0 "Program counter for LMC.")


@@ -71,6 +76,33 @@
 (defvar lmc-acc 0 "Accumulator for LMC.")
 (make-variable-buffer-local 'lmc--acc)
 
 (defvar lmc-acc 0 "Accumulator for LMC.")
 (make-variable-buffer-local 'lmc--acc)
 

+(defvar lmc-turbo nil
+  "When non-nil, evaluate the code without extra delays.
+When nil, evaluation flashes the cursor at to help you see what's going on,
+which slows it down significantly.
+Also, when nil, evaluation is interrupted when the user hits a key.")
+
+;; Emacs-22 backward compatibility.
+(defmacro lmc--with-silent-modifications (&rest body)
+  (declare (debug t) (indent 0))
+  (if (fboundp 'with-silent-modifications)
+      `(with-silent-modifications ,@body)
+    (let ((modified (make-symbol "modified")))
+      `(let* ((,modified (buffer-modified-p))
+             (buffer-undo-list t)
+             (inhibit-read-only t)
+             (inhibit-modification-hooks t)
+             deactivate-mark
+             ;; Avoid setting and removing file locks and checking
+             ;; buffer's uptodate-ness w.r.t the underlying file.
+             buffer-file-name
+             buffer-file-truename)
+        (unwind-protect
+            (progn
+              ,@body)
+          (unless ,modified
+            (restore-buffer-modified-p nil)))))))
+

 ;; (defun lmc-check (cmds)
 ;;   (dolist (cmd cmds)
 ;;     (pcase cmd
 ;; (defun lmc-check (cmds)
 ;;   (dolist (cmd cmds)
 ;;     (pcase cmd


@@ -114,14 +146,26 @@
     ;; First pass, resolve labels to their positions.
     (dolist (cmd cmds)
       (setq cmd (cdr cmd))              ;Ignore position info at this stage.
     ;; First pass, resolve labels to their positions.
     (dolist (cmd cmds)
       (setq cmd (cdr cmd))              ;Ignore position info at this stage.

-      (if (or (consp cmd)
-              (assq cmd lmc-mnemonic-0-table))
-          (setq pos (+ pos (if (eq (car cmd) 'DAT)
-                               (1- (length cmd)) 1)))
+      (cond
+       ((or (consp cmd)
+            (assq cmd lmc-mnemonic-0-table))
+        (setq pos (+ pos (if (eq (car cmd) 'DAT)
+                             (1- (length cmd)) 1))))
+       ((numberp cmd)
+        (cond
+         ((not (and (natnump cmd) (< cmd 100)))
+          (error "%S is not a valid address" cmd))
+         ((< cmd pos)
+          (error "Address %S already used" cmd))
+         ((rassq pos labels)
+          (error "Label %S needs to come after address %S"
+                 (car (rassq pos labels)) cmd))
+         (t (setq pos cmd))))
+       ((and cmd (symbolp cmd))

         ;; (assert (symbolp cmd))
         (if (assq cmd labels)
             (error "Duplicate label %S" cmd)
         ;; (assert (symbolp cmd))
         (if (assq cmd labels)
             (error "Duplicate label %S" cmd)

-          (push (cons cmd pos) labels))))
+          (push (cons cmd pos) labels)))))

     ;; Second pass, do the actual assembly.
     (let* ((words ())
            (ll nil)
     ;; Second pass, do the actual assembly.
     (let* ((words ())
            (ll nil)


@@ -144,6 +188,9 @@
                    (+ (* 100 (cdr (assq (car cmd) lmc-mnemonic-1-table)))
                       (lmc--resolve (nth 1 cmd) labels 100))
                    'code))
                    (+ (* 100 (cdr (assq (car cmd) lmc-mnemonic-1-table)))
                       (lmc--resolve (nth 1 cmd) labels 100))
                    'code))

+         ((numberp cmd)
+          (dotimes (_ (- cmd (length words)))
+            (funcall newword 0)))

          ((and cmd (symbolp cmd))
           (assert (eq (cdr (assq cmd labels)) (length words)))
           (setq ll cmd))
          ((and cmd (symbolp cmd))
           (assert (eq (cdr (assq cmd labels)) (length words)))
           (setq ll cmd))


@@ -161,8 +208,7 @@
   (let ((word (car word))
         (label (nth 1 word))
         (code (nth 2 word)))
   (let ((word (car word))
         (label (nth 1 word))
         (code (nth 2 word)))

-    (let ((basepos (point))
-          (base (current-column)))
+    (let () ;; ((basepos (point)) (base (current-column)))

       (if (and label (symbolp label))
           (insert (symbol-name label)))
       ;; (when (>= (current-column) (+ base tab-width))
       (if (and label (symbolp label))
           (insert (symbol-name label)))
       ;; (when (>= (current-column) (+ base tab-width))


@@ -303,7 +349,7 @@
      (2 (lmc-font-lock-label)))
     (".$" (0 (lmc-font-lock-opcode)))))
 
      (2 (lmc-font-lock-label)))
     (".$" (0 (lmc-font-lock-opcode)))))
 

-(defun lmc-after-change (beg end len)
+(defun lmc-after-change (beg end _len)

   (unless inhibit-read-only
     (save-excursion
       ;; Replace any TAB or NL inserted, which could interfere with parsing.
   (unless inhibit-read-only
     (save-excursion
       ;; Replace any TAB or NL inserted, which could interfere with parsing.


@@ -316,7 +362,7 @@
 (make-variable-buffer-local 'lmc-pc)
 (defvar lmc-acc nil "LMC accumulator.")
 (make-variable-buffer-local 'lmc-acc)
 (make-variable-buffer-local 'lmc-pc)
 (defvar lmc-acc nil "LMC accumulator.")
 (make-variable-buffer-local 'lmc-acc)

-(defvar lmc-output nil "Past LMC output,")
+(defvar lmc-output nil "Past LMC output.")

 (make-variable-buffer-local 'lmc-output)
 
 (defvar lmc--stopped nil "State where we stopped.")
 (make-variable-buffer-local 'lmc-output)
 
 (defvar lmc--stopped nil "State where we stopped.")


@@ -361,15 +407,52 @@
 (defvar lmc-tool-bar-map
   (let ((map (make-sparse-keymap)))
     (tool-bar-local-item "gud/next" 'lmc-step 'step map
 (defvar lmc-tool-bar-map
   (let ((map (make-sparse-keymap)))
     (tool-bar-local-item "gud/next" 'lmc-step 'step map

-                         :label "step" ;; :vert-only t
+                         :label "Step" ;; :vert-only t

                          :enable '(not (lmc-stopped-p))
                          )
     (tool-bar-local-item "gud/run" 'lmc-run 'run map
                          :enable '(not (lmc-stopped-p))
                          )
     (tool-bar-local-item "gud/run" 'lmc-run 'run map

-                         :label "run" ;; :vert-only t
+                         :label "Run" ;; :vert-only t

                          :enable '(not (lmc-stopped-p))
                          )
     map))
 
                          :enable '(not (lmc-stopped-p))
                          )
     map))
 

+(defun lmc-tool-bar-to-string (&optional map)
+  (let ((res ""))
+    (map-keymap
+     (lambda (_k v)
+       (when (eq (car v) 'menu-item)
+         (let* ((label (nth 1 v))
+                (cmd (nth 2 v))
+                (plist (nthcdr (if (consp (nth 3 v)) 4 3) v))
+                (help-echo (plist-get plist :help))
+                (image     (plist-get plist :image))
+                (enable-exp (if (plist-member plist :enable)
+                                (plist-get plist :enable)
+                              t))
+                (enable (eval enable-exp))
+                (map (let ((map (make-sparse-keymap)))
+                       (define-key map [header-line mouse-1] cmd)
+                       (define-key map [header-line mouse-2] cmd)
+                       map))
+                (button
+                 (propertize " " 'help-echo (or help-echo label)
+                             'keymap map
+                             'face 'header-line
+                             'mouse-face (if enable 'mode-line-highlight)
+                             'rear-nonsticky '(display keymap help-echo)
+                             'display (if (and (eq 'image (car image))
+                                               (not enable))
+                                          `(image :conversion disabled
+                                                  ,@(cdr image))
+                                        image))))
+           (setq res (concat res (propertize " " 'display '(space :width 0.5)
+                                             'face 'header-line
+                                             )
+                             button)))))
+     (or (let ((tool-bar-map map)) (tool-bar-make-keymap))
+         (key-binding [tool-bar])))
+    res))
+

 (define-derived-mode lmc-mode fundamental-mode "LMC-Sim"
   "The simulator of the Little Man Computer."
   (set (make-local-variable 'truncate-lines) t)
 (define-derived-mode lmc-mode fundamental-mode "LMC-Sim"
   "The simulator of the Little Man Computer."
   (set (make-local-variable 'truncate-lines) t)


@@ -379,17 +462,21 @@
        '(lmc-font-lock-keywords t))
   (set (make-local-variable 'font-lock-extra-managed-props)
        '(display help-echo))
        '(lmc-font-lock-keywords t))
   (set (make-local-variable 'font-lock-extra-managed-props)
        '(display help-echo))

-  (set (make-local-variable 'tool-bar-map) lmc-tool-bar-map)
+  ;; (set (make-local-variable 'tool-bar-map) lmc-tool-bar-map)

   (add-hook 'after-change-functions #'lmc-after-change nil t)
   (set (make-local-variable 'lmc-label-table) (make-vector 100 nil))
   (set (make-local-variable 'overlay-arrow-position) (point-min-marker))
   (lmc-update-pc)
   ;; (overwrite-mode 1)
   (set (make-local-variable 'header-line-format)
   (add-hook 'after-change-functions #'lmc-after-change nil t)
   (set (make-local-variable 'lmc-label-table) (make-vector 100 nil))
   (set (make-local-variable 'overlay-arrow-position) (point-min-marker))
   (lmc-update-pc)
   ;; (overwrite-mode 1)
   (set (make-local-variable 'header-line-format)

-       `("LMC-Sim  PC="
+       `(""
+         (:eval (lmc-tool-bar-to-string lmc-tool-bar-map))
+         "  " ,(propertize "LMC-Sim" 'face '(bold italic)) "  "
+         ,(propertize "PC=" 'face 'font-lock-function-name-face)

          (:eval (format ,(propertize "%02d"
                                      'mouse-face 'mode-line-highlight
          (:eval (format ,(propertize "%02d"
                                      'mouse-face 'mode-line-highlight

-                                     'help-echo "mouse-2: set the Program Counter"
+                                     'help-echo
+                                     "mouse-2: set the Program Counter"

                                      'follow-link t
                                      ;; I'm having problems with mouse-2 to
                                      ;; mouse-1 remapping in the mode-line and
                                      'follow-link t
                                      ;; I'm having problems with mouse-2 to
                                      ;; mouse-1 remapping in the mode-line and


@@ -401,7 +488,7 @@
                                                     (mouse-2 . lmc-set-pc)
                                                     (mouse-1 . lmc-set-pc))))
                         lmc-pc))
                                                     (mouse-2 . lmc-set-pc)
                                                     (mouse-1 . lmc-set-pc))))
                         lmc-pc))

-         "  ACC="
+         "  " ,(propertize "ACC=" 'face 'font-lock-function-name-face)

          (:eval (format ,(propertize "%03d"
                                      'mouse-face 'mode-line-highlight
                                      'help-echo "mouse-2: set the Accumulator"
          (:eval (format ,(propertize "%03d"
                                      'mouse-face 'mode-line-highlight
                                      'help-echo "mouse-2: set the Accumulator"


@@ -416,7 +503,8 @@
                                                     (mouse-2 . lmc-set-acc)
                                                     (mouse-1 . lmc-set-acc))))
                         lmc-acc))
                                                     (mouse-2 . lmc-set-acc)
                                                     (mouse-1 . lmc-set-acc))))
                         lmc-acc))

-         "      Recent output: "
+         "      " ,(propertize "Recent output="
+                               'face 'font-lock-function-name-face)

          (:eval (if lmc-output (format "%s" lmc-output) "()"))))
   )
 
          (:eval (if lmc-output (format "%s" lmc-output) "()"))))
   )
 


@@ -448,29 +536,33 @@
       (setq addr (1+ addr))))
   (lmc-update-pc))
 
       (setq addr (1+ addr))))
   (lmc-update-pc))
 

-(defvar lmc-store-flash t)
+(defcustom lmc-store-flash t
+  "If non-nil, memory words blink when modified."
+  :type 'boolean)
+
+(defun lmc--sit-for (secs)
+  (unless lmc-turbo (sit-for secs)))

 
 (defun lmc-store-word (addr word)
   (save-excursion
     (lmc-addr->point addr)
     (if (not (re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t))
         (error "Missing memory cell %S" addr)
 
 (defun lmc-store-word (addr word)
   (save-excursion
     (lmc-addr->point addr)
     (if (not (re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t))
         (error "Missing memory cell %S" addr)

-      (when lmc-store-flash
-        (with-silent-modifications
-          (put-text-property (match-beginning 1) (point)
-                             'face 'region))
-        (sit-for 0.2))
-      (replace-match (format "  %03d" word) t t nil 1)
-      (when lmc-store-flash
-        (sit-for 0.1)
-        (with-silent-modifications
-          (put-text-property (match-beginning 1) (point)
-                             'face 'region))
-        (sit-for 0.1)
-        (with-silent-modifications
-          (put-text-property (match-beginning 1) (point)
-                             'face nil))
-        (sit-for 0.1)))))
+      (let ((mb1 (match-beginning 1)))
+        (when lmc-store-flash
+          (lmc--with-silent-modifications
+           (put-text-property mb1 (point) 'face 'region))
+          (lmc--sit-for 0.2))
+        (let ((me1 (point)))
+          (insert (format "  %03d" word)) (delete-region mb1 me1))
+        (when lmc-store-flash
+          (lmc--sit-for 0.1)
+          (lmc--with-silent-modifications
+           (put-text-property mb1 (point) 'face 'region))
+          (lmc--sit-for 0.1)
+          (lmc--with-silent-modifications
+           (put-text-property mb1 (point) 'face nil))
+          (lmc--sit-for 0.1))))))

 
 (defun lmc-step ()
   "Execute one LMC instruction."
 
 (defun lmc-step ()
   "Execute one LMC instruction."


@@ -483,7 +575,7 @@
              (setq lmc--stopped (lmc--state))
              (force-mode-line-update)
              (message "Done.")))
              (setq lmc--stopped (lmc--state))
              (force-mode-line-update)
              (message "Done.")))

-      (IN (setq lmc-acc (mod (read-number "Enter a number") 1000))
+      (IN (setq lmc-acc (mod (read-number "Enter a number: ") 1000))

           (incf lmc-pc))
       (OUT (message "Output: %03d" lmc-acc)
            (push (format "%03d" lmc-acc) lmc-output)
           (incf lmc-pc))
       (OUT (message "Output: %03d" lmc-acc)
            (push (format "%03d" lmc-acc) lmc-output)


@@ -513,9 +605,9 @@
   "Run the code until hitting a HLT.
 The machine will also stop if the user presses a key."
   (interactive)
   "Run the code until hitting a HLT.
 The machine will also stop if the user presses a key."
   (interactive)

-  (while (not (or (input-pending-p) (lmc-stopped-p)))
+  (while (not (or (unless lmc-turbo (input-pending-p)) (lmc-stopped-p)))

     (lmc-step)
     (lmc-step)

-    (sit-for 0.05)))
+    (lmc--sit-for 0.05)))

 
 ;;; The LMC assembly language editor.
 
 
 ;;; The LMC assembly language editor.
 


@@ -618,7 +710,8 @@ The machine will also stop if the user presses a key."
     (cond
      ((> (nth 0 (syntax-ppss)) 0) nil)
      ((looking-at "(") tab-width)
     (cond
      ((> (nth 0 (syntax-ppss)) 0) nil)
      ((looking-at "(") tab-width)

-     ((not (looking-at comment-start-skip)) 0)
+     ((not (looking-at comment-start-skip))
+      (if (looking-at "[ \t]*$") tab-width 0))

      ((not (looking-at "\\s<\\s<")) nil)
      ((save-excursion (forward-comment (- (point))) (bobp)) 0)
      (t (forward-comment (point-max)) (lmc-asm-indentation)))))
      ((not (looking-at "\\s<\\s<")) nil)
      ((save-excursion (forward-comment (- (point))) (bobp)) 0)
      (t (forward-comment (point-max)) (lmc-asm-indentation)))))