code.delx.au - gnu-emacs-elpa/blob - packages/lmc/lmc.el

   1 ;;; lmc.el --- Little Man Computer in Elisp
   2
   3 ;; Copyright (C) 2011, 2013, 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Version: 1.3
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; A simulator for the Little Man Computer.
  24 ;; http://en.wikipedia.org/wiki/Little_man_computer
  25
  26 ;; The simulator uses a plain editable buffer, so you can edit the machine
  27 ;; words just like any other text, and every word can be given a name (label)
  28 ;; which can also be edited in the normal way.  Additionally to the labels it
  29 ;; shows the disassembled meaning of instruction words.  Of course, it can't
  30 ;; always know which words are meant to be code rather than data, so it relies
  31 ;; on information from the assembler to do that, and otherwise just marks every
  32 ;; word it executes as being "code".
  33
  34 ;; The assembly uses a slightly different (Lispish) syntax where comments start
  35 ;; with ";", and each instruction needs to be wrapped in parentheses.
  36 ;; Other than that it's the same assembly as documented elsewhere
  37 ;; (accepts a few mnemonic variants, such as IN/INP, STA/STO, BR/BRA).
  38 ;; Another difference is that the DAT mnemonic accepts any number of words
  39 ;; rather than just one.
  40 ;;
  41 ;; So the assembly (stored in files with extension ".elmc") looks like:
  42 ;;
  43 ;;   label1
  44 ;;          (BR label2) ;Useless extra jump.
  45 ;;   label2
  46 ;;          (LDA data1) ;Cleverest part of the algorithm.
  47 ;;          (ADD data2)
  48 ;;          (STO data1)
  49 ;;          (BR label1)
  50 ;;
  51 ;;   data1  (DAT 0)
  52 ;;   data2  (DAT 050 060 070)
  53 ;;
  54 ;; And actually, since the assembler re-uses the Emacs Lisp reader to parse the
  55 ;; code, you can use binary, octal, and hexadecimal constants as well, using
  56 ;; the notations #b101010, #o277, and #x5F respectively.
  57 ;;
  58 ;; The lmc-asm-mode supports the usual editing features such as label
  59 ;; completion, mnemonic completion, jumping to a label, automatic indentation,
  60 ;; and code folding.
  61
  62 ;;; Code:
  63
  64 (eval-when-compile (require 'cl))
  65 (require 'hexl)
  66
  67 (defgroup lmc ()
  68   "Customization group for the Little Man Computer simulator."
  69   :group 'languages)
  70
  71 ;;; The LMC-Simulator
  72
  73 (defvar lmc--pc 0 "Program counter for LMC.")
  74 (make-variable-buffer-local 'lmc--pc)
  75
  76 (defvar lmc-acc 0 "Accumulator for LMC.")
  77 (make-variable-buffer-local 'lmc--acc)
  78
  79 (defvar lmc-turbo nil
  80   "When non-nil, evaluate the code without extra delays.
  81 When nil, evaluation flashes the cursor at to help you see what's going on,
  82 which slows it down significantly.
  83 Also, when nil, evaluation is interrupted when the user hits a key.")
  84
  85 ;; Emacs-22 backward compatibility.
  86 (defmacro lmc--with-silent-modifications (&rest body)
  87   (declare (debug t) (indent 0))
  88   (if (fboundp 'with-silent-modifications)
  89       `(with-silent-modifications ,@body)
  90     (let ((modified (make-symbol "modified")))
  91       `(let* ((,modified (buffer-modified-p))
  92               (buffer-undo-list t)
  93               (inhibit-read-only t)
  94               (inhibit-modification-hooks t)
  95               deactivate-mark
  96               ;; Avoid setting and removing file locks and checking
  97               ;; buffer's uptodate-ness w.r.t the underlying file.
  98               buffer-file-name
  99               buffer-file-truename)
 100          (unwind-protect
 101              (progn
 102                ,@body)
 103            (unless ,modified
 104              (restore-buffer-modified-p nil)))))))
 105
 106 ;; (defun lmc-check (cmds)
 107 ;;   (dolist (cmd cmds)
 108 ;;     (pcase cmd
 109 ;;       ((pred symbolp))                                ;A label.
 110 ;;       (`(,(or `IN `OUT `HLT `COB)))                   ;Arity-0 opcode.
 111 ;;       (`(,(or `LDA `STO `ADD `SUB `BR `BRZ `BRP `DAT) ;Arity-1 opcode.
 112 ;;          ,(or (pred lmc--numberp) (pred symbolp))))
 113 ;;       (_ (error "Unknown instruction %S" cmd)))))
 114
 115 (defun lmc--numberp (n max)
 116   (when (numberp n)
 117     (or (and (or (natnump n) (error "%S is not a positive integer" n))
 118              (or (< n max) (error "%S is too large" n))))))
 119
 120 (defun lmc--resolve (arg labels max)
 121   (if (lmc--numberp arg max) arg
 122     (or (cdr (assq arg labels))
 123         (error (if (symbolp arg)
 124                    "Unknown label %S"
 125                  "Arg %S is neither a label nor a number")
 126                arg))))
 127
 128 (defconst lmc-mnemonic-1-table '((LDA . 5)
 129                                  (STO . 3) (STA . 3)
 130                                  (ADD . 1)
 131                                  (SUB . 2)
 132                                  (BR . 6) (BRA . 6)
 133                                  (BRZ . 7)
 134                                  (BRP . 8))
 135   "Mnemonic table for arity-1 instructions.")
 136
 137 (defconst lmc-mnemonic-0-table '((HLT . 000) (COB . 000)
 138                                  (IN . 901) (INP . 901)
 139                                  (OUT . 902))
 140   "Mnemonic table for arity-0 instructions.")
 141
 142 (defun lmc--assemble (cmds)
 143   ;; FIXME: Move to error position upon error.
 144   (let ((pos 0)
 145         (labels ()))
 146     ;; First pass, resolve labels to their positions.
 147     (dolist (cmd cmds)
 148       (setq cmd (cdr cmd))              ;Ignore position info at this stage.
 149       (cond
 150        ((or (consp cmd)
 151             (assq cmd lmc-mnemonic-0-table))
 152         (setq pos (+ pos (if (eq (car cmd) 'DAT)
 153                              (1- (length cmd)) 1))))
 154        ((numberp cmd)
 155         (cond
 156          ((not (and (natnump cmd) (< cmd 100)))
 157           (error "%S is not a valid address" cmd))
 158          ((< cmd pos)
 159           (error "Address %S already used" cmd))
 160          ((rassq pos labels)
 161           (error "Label %S needs to come after address %S"
 162                  (car (rassq pos labels)) cmd))
 163          (t (setq pos cmd))))
 164        ((and cmd (symbolp cmd))
 165         ;; (assert (symbolp cmd))
 166         (if (assq cmd labels)
 167             (error "Duplicate label %S" cmd)
 168           (push (cons cmd pos) labels)))))
 169     ;; Second pass, do the actual assembly.
 170     (let* ((words ())
 171            (ll nil)
 172            (newword
 173             (lambda (w &optional code)
 174               (push (list w ll code) words) (setq ll nil))))
 175       (dolist (cmd cmds)
 176         (goto-char (pop cmd))          ;Move to start of CMD, in case of error.
 177         (cond
 178          ((assq cmd lmc-mnemonic-0-table)
 179           (funcall newword (cdr (assq cmd lmc-mnemonic-0-table)) 'code))
 180          ((and (null (cdr-safe cmd))
 181                (assq (car-safe cmd) lmc-mnemonic-0-table))
 182           (funcall newword (cdr (assq (car cmd) lmc-mnemonic-0-table)) 'code))
 183          ((eq (car-safe cmd) 'DAT)
 184           (dolist (arg (cdr cmd))
 185             (funcall newword (lmc--resolve arg labels 1000))))
 186          ((assq (car-safe cmd) lmc-mnemonic-1-table)
 187           (funcall newword
 188                    (+ (* 100 (cdr (assq (car cmd) lmc-mnemonic-1-table)))
 189                       (lmc--resolve (nth 1 cmd) labels 100))
 190                    'code))
 191          ((numberp cmd)
 192           (dotimes (_ (- cmd (length words)))
 193             (funcall newword 0)))
 194          ((and cmd (symbolp cmd))
 195           (assert (eq (cdr (assq cmd labels)) (length words)))
 196           (setq ll cmd))
 197          (t (error "Invalid instruction %S" cmd))))
 198       (nreverse words))))
 199
 200 ;; (defvar lmc-label-width 8)
 201
 202 (defun lmc--load-word (word addr)
 203   (assert (bolp))
 204   (insert (propertize (format " %02d:\t" addr)
 205                       'read-only t
 206                       'front-sticky t
 207                       'rear-nonsticky t))
 208   (let ((word (car word))
 209         (label (nth 1 word))
 210         (code (nth 2 word)))
 211     (let ((basepos (point))
 212           (base (current-column)))
 213       (if (and label (symbolp label))
 214           (insert (symbol-name label)))
 215       ;; (when (>= (current-column) (+ base tab-width))
 216       ;;   (while (>= (current-column) (+ base tab-width -1))
 217       ;;     (delete-char -1))
 218       ;;   (insert "…")
 219       ;;   (put-text-property basepos (point)
 220       ;;                      'help-echo (symbol-name label)))
 221       ;; (insert (propertize
 222       ;;      (make-string (1+ (- lmc-label-width (current-column))) ?\s)
 223       ;;      'display '(space :align-to (1+ lmc-label-width))))
 224       (insert (eval-when-compile (propertize "\t"
 225                                              'read-only t
 226                                              'rear-nonsticky t))))
 227     (insert (format "  %03d" word))
 228     (insert (if code
 229                 (eval-when-compile (propertize "\n"
 230                                                'lmc-code t
 231                                                'read-only t
 232                                                'rear-nonsticky t))
 233               (eval-when-compile (propertize "\n"
 234                                              'read-only t
 235                                              'rear-nonsticky t))))))
 236
 237 (defun lmc-disassemble-word (word)
 238   (let ((code (car (rassq (/ word 100) lmc-mnemonic-1-table))))
 239     (cond
 240      (code (list code (mod word 100)))
 241      ((rassq word lmc-mnemonic-0-table)
 242       (list (car (rassq word lmc-mnemonic-0-table)))))))
 243
 244 (defun lmc-addr->point (addr)
 245   (goto-char (point-min))
 246   (forward-line addr))
 247
 248 (defun lmc-point->addr ()
 249   (- (count-lines (point-min) (point)) (if (bolp) 0 1)))
 250
 251 (defun lmc-get-word (&optional addr fix)
 252   (save-excursion
 253     (if (null addr)
 254         (forward-line 0)
 255       (lmc-addr->point addr))
 256     (cond
 257      ((re-search-forward "\t.*\t  \\([0-9][0-9][0-9]\\)$"
 258                          (line-end-position) t)
 259       (string-to-number (match-string 1)))
 260      ((re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t)
 261       (let ((n (string-to-number (match-string 1))))
 262         (unless (integerp n) (setq n (truncate n)))
 263         (setq n (mod n 1000))
 264         (when fix
 265           (replace-match (format "  %03d" n) t t nil 1))
 266         n))
 267      (t 0))))
 268
 269 (defconst lmc-label-re "^\\([^\t\n]*\\)\t\\(.*\\)\t *[0-9]")
 270
 271 (defvar lmc-label-table nil)
 272
 273 (defun lmc-record-label (addr label)
 274   (let ((old (aref lmc-label-table addr)))
 275     (unless (and old (equal (car old) label))
 276       ;; (message "recordlabel %S = %S" addr label)
 277       (aset lmc-label-table addr (list label))
 278       (when (cdr old)
 279         (run-with-timer
 280          0 nil
 281          (lambda (buf refaddrs)
 282            (with-current-buffer buf
 283              (save-excursion
 284                ;; (message "refreshlabel in %S" refaddrs)
 285                (dolist (refaddr refaddrs)
 286                  (lmc-addr->point (1+ refaddr))
 287                  (unless (bobp)
 288                    (let ((inhibit-read-only t))
 289                      (put-text-property (1- (point)) (point)
 290                                         'fontified nil)))))))
 291          (current-buffer) (cdr old))))))
 292
 293 (defun lmc-get-label (addr)
 294   (save-excursion
 295     ;; (if (null addr)
 296     ;;     (forward-line 0)
 297     (lmc-addr->point addr) ;; )
 298     (let ((label (when (re-search-forward lmc-label-re nil t)
 299                    (if (> (match-end 2) (match-beginning 2))
 300                        (match-string 2)))))
 301       (lmc-record-label addr label)
 302       label)))
 303
 304
 305 (defun lmc-font-lock-opcode ()
 306   (save-match-data
 307     (when (get-text-property (line-end-position) 'lmc-code)
 308       (let* ((word (lmc-get-word))
 309              (code (lmc-disassemble-word word)))
 310         ;; Resolve labels.
 311         (when (integerp (nth 1 code))
 312           (let* ((addr (nth 1 code))
 313                  (label (lmc-get-label addr)))
 314             (pushnew (lmc-point->addr)
 315                      (cdr (aref lmc-label-table addr)))
 316             (when label
 317               (setf (nth 1 code) label))))
 318         (put-text-property
 319          (line-end-position) (1+ (line-end-position))
 320          'display
 321          (format (eval-when-compile
 322                    (concat (propertize "\t" 'cursor t)
 323                            (propertize "%s" 'face font-lock-comment-face)
 324                            "\n"))
 325                  (or code '(Invalid opcode)))))
 326       nil)))
 327
 328 (defun lmc-font-lock-label ()
 329   (lmc-record-label (lmc-point->addr)
 330                     (if (> (match-end 2) (match-beginning 2))
 331                        (match-string 2)))
 332   (save-excursion
 333     ;; ;; Replace any TAB found in label.
 334     ;; (goto-char (match-beginning 2))
 335     ;; (while (progn (skip-chars-forward "^\t" (match-end 2))
 336     ;;               (< (point) (match-end 2)))
 337     ;;   (insert " ") (delete-char 1))
 338     ;; Truncate label's display if needed.
 339     (move-to-column (1- (* 2 tab-width)))
 340     (when (> (match-end 2) (point))
 341       (forward-char -1)
 342       (put-text-property (match-beginning 2) (match-end 2)
 343                          'help-echo (match-string 2))
 344       (put-text-property (point) (match-end 2) 'display "…")))
 345   font-lock-constant-face)
 346
 347 (defconst lmc-font-lock-keywords
 348   `((,lmc-label-re
 349      (1 'hexl-address-region)
 350      (2 (lmc-font-lock-label)))
 351     (".$" (0 (lmc-font-lock-opcode)))))
 352
 353 (defun lmc-after-change (beg end len)
 354   (unless inhibit-read-only
 355     (save-excursion
 356       ;; Replace any TAB or NL inserted, which could interfere with parsing.
 357       (goto-char beg)
 358       (while (progn (skip-chars-forward "^\t\n" end)
 359                     (< (point) end))
 360         (insert " ") (delete-char 1)))))
 361
 362 (defvar lmc-pc 0 "LMC program counter.")
 363 (make-variable-buffer-local 'lmc-pc)
 364 (defvar lmc-acc nil "LMC accumulator.")
 365 (make-variable-buffer-local 'lmc-acc)
 366 (defvar lmc-output nil "Past LMC output,")
 367 (make-variable-buffer-local 'lmc-output)
 368
 369 (defvar lmc--stopped nil "State where we stopped.")
 370 (make-variable-buffer-local 'lmc--stopped)
 371
 372 (defun lmc-update-pc ()
 373   (setq lmc-pc (mod lmc-pc 100))
 374   (lmc-addr->point lmc-pc)
 375   (move-marker overlay-arrow-position (point))
 376   (re-search-forward "\t.*\t *" nil t)
 377   (unless (get-text-property (line-end-position) 'lmc-code)
 378     (let ((inhibit-read-only t))
 379       (put-text-property (line-end-position)
 380                          (min (1+ (line-end-position)) (point-max))
 381                          'lmc-code t))))
 382
 383 (defun lmc--state ()
 384   (list (buffer-chars-modified-tick) lmc-acc lmc-pc))
 385 (defun lmc-stopped-p ()
 386   (equal (lmc--state) lmc--stopped))
 387
 388 ;; FIXME: Add tool-bar to LMC-Sim.
 389
 390 (defvar lmc-mode-map
 391   (let ((map (make-sparse-keymap)))
 392     (define-key map "\C-c\C-s" 'lmc-step)
 393     (define-key map "\C-c\C-r" 'lmc-run)
 394     (define-key map "\C-c\C-l" 'lmc-load-file)
 395     (define-key map "\C-c\C-a" 'lmc-set-acc)
 396     (define-key map "\C-c\C-p" 'lmc-set-pc)
 397     map))
 398
 399 (easy-menu-define lmc-menu lmc-mode-map "Menu for LMC-Sim."
 400   '("LMC-Sim"
 401     ["Step" lmc-step (not (lmc-stopped-p))]
 402     ["Run" lmc-run (not (lmc-stopped-p))]
 403     ["Load file" lmc-load-file]
 404     "--"
 405     ["Set Program Counter" lmc-set-pc]
 406     ["Set Accumulator" lmc-set-acc]))
 407
 408 (defvar lmc-tool-bar-map
 409   (let ((map (make-sparse-keymap)))
 410     (tool-bar-local-item "gud/next" 'lmc-step 'step map
 411                          :label "Step" ;; :vert-only t
 412                          :enable '(not (lmc-stopped-p))
 413                          )
 414     (tool-bar-local-item "gud/run" 'lmc-run 'run map
 415                          :label "Run" ;; :vert-only t
 416                          :enable '(not (lmc-stopped-p))
 417                          )
 418     map))
 419
 420 (defun lmc-tool-bar-to-string (&optional map)
 421   (let ((res ""))
 422     (map-keymap
 423      (lambda (k v)
 424        (when (eq (car v) 'menu-item)
 425          (let* ((label (nth 1 v))
 426                 (cmd (nth 2 v))
 427                 (plist (nthcdr (if (consp (nth 3 v)) 4 3) v))
 428                 (help-echo (plist-get plist :help))
 429                 (image     (plist-get plist :image))
 430                 (enable-exp (if (plist-member plist :enable)
 431                                 (plist-get plist :enable)
 432                               t))
 433                 (enable (eval enable-exp))
 434                 (map (let ((map (make-sparse-keymap)))
 435                        (define-key map [header-line mouse-1] cmd)
 436                        (define-key map [header-line mouse-2] cmd)
 437                        map))
 438                 (button
 439                  (propertize " " 'help-echo (or help-echo label)
 440                              'keymap map
 441                              'face 'header-line
 442                              'mouse-face (if enable 'mode-line-highlight)
 443                              'rear-nonsticky '(display keymap help-echo)
 444                              'display (if (and (eq 'image (car image))
 445                                                (not enable))
 446                                           `(image :conversion disabled
 447                                                   ,@(cdr image))
 448                                         image))))
 449            (setq res (concat res (propertize " " 'display '(space :width 0.5)
 450                                              'face 'header-line
 451                                              )
 452                              button)))))
 453      (or (let ((tool-bar-map map)) (tool-bar-make-keymap))
 454          (key-binding [tool-bar])))
 455     res))
 456
 457 (define-derived-mode lmc-mode fundamental-mode "LMC-Sim"
 458   "The simulator of the Little Man Computer."
 459   (set (make-local-variable 'truncate-lines) t)
 460   (set (make-local-variable 'truncate-partial-width-windows) t)
 461   (set (make-local-variable 'tab-width) 10)
 462   (set (make-local-variable 'font-lock-defaults)
 463        '(lmc-font-lock-keywords t))
 464   (set (make-local-variable 'font-lock-extra-managed-props)
 465        '(display help-echo))
 466   ;; (set (make-local-variable 'tool-bar-map) lmc-tool-bar-map)
 467   (add-hook 'after-change-functions #'lmc-after-change nil t)
 468   (set (make-local-variable 'lmc-label-table) (make-vector 100 nil))
 469   (set (make-local-variable 'overlay-arrow-position) (point-min-marker))
 470   (lmc-update-pc)
 471   ;; (overwrite-mode 1)
 472   (set (make-local-variable 'header-line-format)
 473        `(""
 474          (:eval (lmc-tool-bar-to-string lmc-tool-bar-map))
 475          "  " ,(propertize "LMC-Sim" 'face '(bold italic)) "  "
 476          ,(propertize "PC=" 'face 'font-lock-function-name-face)
 477          (:eval (format ,(propertize "%02d"
 478                                      'mouse-face 'mode-line-highlight
 479                                      'help-echo
 480                                      "mouse-2: set the Program Counter"
 481                                      'follow-link t
 482                                      ;; I'm having problems with mouse-2 to
 483                                      ;; mouse-1 remapping in the mode-line and
 484                                      ;; header-line, so I over-do it a bit.
 485                                      'keymap
 486                                      '(keymap
 487                                        (header-line keymap
 488                                                     (down-mouse-1 . ignore)
 489                                                     (mouse-2 . lmc-set-pc)
 490                                                     (mouse-1 . lmc-set-pc))))
 491                         lmc-pc))
 492          "  " ,(propertize "ACC=" 'face 'font-lock-function-name-face)
 493          (:eval (format ,(propertize "%03d"
 494                                      'mouse-face 'mode-line-highlight
 495                                      'help-echo "mouse-2: set the Accumulator"
 496                                      'follow-link t
 497                                      'keymap
 498                                      ;; I'm having problems with mouse-2 to
 499                                      ;; mouse-1 remapping in the mode-line and
 500                                      ;; header-line, so I over-do it a bit.
 501                                      '(keymap
 502                                        (header-line keymap
 503                                                     (down-mouse-1 . ignore)
 504                                                     (mouse-2 . lmc-set-acc)
 505                                                     (mouse-1 . lmc-set-acc))))
 506                         lmc-acc))
 507          "      " ,(propertize "Recent output="
 508                                'face 'font-lock-function-name-face)
 509          (:eval (if lmc-output (format "%s" lmc-output) "()"))))
 510   )
 511
 512 (defun lmc-set-pc (pc)
 513   "Set the Program Counter."
 514   (interactive (list (read-number "New PC: " lmc-pc)))
 515   (setq lmc-pc pc)
 516   (lmc-update-pc))
 517
 518 (defun lmc-set-acc (acc)
 519   "Set the Accumulator."
 520   (interactive (list (read-number "New Accumulator: " lmc-acc)))
 521   (setq lmc-acc (mod acc 1000)))
 522
 523 (defun lmc-load (words)
 524   (pop-to-buffer "*LMC-Sim*")
 525   (lmc-mode)
 526   (let ((inhibit-read-only t)
 527         (addr 0))
 528     (setq lmc-pc 0)
 529     (setq lmc-acc 0)
 530     (setq lmc-output nil)
 531     (erase-buffer)
 532     (dolist (word words)
 533       (lmc--load-word word addr)
 534       (setq addr (1+ addr)))
 535     (while (< addr 100)
 536       (lmc--load-word '(0) addr)
 537       (setq addr (1+ addr))))
 538   (lmc-update-pc))
 539
 540 (defcustom lmc-store-flash t
 541   "If non-nil, memory words blink when modified."
 542   :type 'boolean)
 543
 544 (defun lmc--sit-for (secs)
 545   (unless lmc-turbo (sit-for secs)))
 546
 547 (defun lmc-store-word (addr word)
 548   (save-excursion
 549     (lmc-addr->point addr)
 550     (if (not (re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t))
 551         (error "Missing memory cell %S" addr)
 552       (let ((mb1 (match-beginning 1)))
 553         (when lmc-store-flash
 554           (lmc--with-silent-modifications
 555            (put-text-property mb1 (point) 'face 'region))
 556           (lmc--sit-for 0.2))
 557         (let ((me1 (point)))
 558           (insert (format "  %03d" word)) (delete-region mb1 me1))
 559         (when lmc-store-flash
 560           (lmc--sit-for 0.1)
 561           (lmc--with-silent-modifications
 562            (put-text-property mb1 (point) 'face 'region))
 563           (lmc--sit-for 0.1)
 564           (lmc--with-silent-modifications
 565            (put-text-property mb1 (point) 'face nil))
 566           (lmc--sit-for 0.1))))))
 567
 568 (defun lmc-step ()
 569   "Execute one LMC instruction."
 570   (interactive)
 571   (let* ((inst (lmc-get-word lmc-pc 'fix))
 572          (code (lmc-disassemble-word inst)))
 573     (case (car code)
 574       (HLT (if (lmc-stopped-p)
 575                (error "Already halted")
 576              (setq lmc--stopped (lmc--state))
 577              (force-mode-line-update)
 578              (message "Done.")))
 579       (IN (setq lmc-acc (mod (read-number "Enter a number: ") 1000))
 580           (incf lmc-pc))
 581       (OUT (message "Output: %03d" lmc-acc)
 582            (push (format "%03d" lmc-acc) lmc-output)
 583            (incf lmc-pc))
 584       (LDA (setq lmc-acc (lmc-get-word (nth 1 code)))
 585            (incf lmc-pc))
 586       (STO (lmc-store-word (nth 1 code) lmc-acc)
 587            (incf lmc-pc))
 588       (ADD (setq lmc-acc (mod (+ lmc-acc (lmc-get-word (nth 1 code)))
 589                               1000))
 590            (incf lmc-pc))
 591       (SUB (setq lmc-acc (mod (- lmc-acc (lmc-get-word (nth 1 code)))
 592                               1000))
 593            (incf lmc-pc))
 594       (BR (setq lmc-pc (nth 1 code)))
 595       (BRZ (setq lmc-pc (if (zerop lmc-acc)
 596                             (nth 1 code)
 597                           (1+ lmc-pc))))
 598       (BRP (setq lmc-pc (if (< lmc-acc 500)
 599                             (nth 1 code)
 600                           (1+ lmc-pc))))
 601       ((nil) (error "Invalid instruction %S" inst))
 602       (t (error "%S not implemented" code))))
 603   (lmc-update-pc))
 604
 605 (defun lmc-run ()
 606   "Run the code until hitting a HLT.
 607 The machine will also stop if the user presses a key."
 608   (interactive)
 609   (while (not (or (unless lmc-turbo (input-pending-p)) (lmc-stopped-p)))
 610     (lmc-step)
 611     (lmc--sit-for 0.05)))
 612
 613 ;;; The LMC assembly language editor.
 614
 615 (defvar lmc-asm-mode-map
 616   (let ((map (make-sparse-keymap)))
 617     ;; FIXME: Add "load" and "assemble" buttons.
 618     (define-key map "\C-c\C-l" 'lmc-asm-load)
 619     (define-key map "\C-c\C-a" 'lmc-asm-assemble)
 620     map))
 621
 622 (easy-menu-define lmc-asm-menu lmc-asm-mode-map
 623   "Menu for the LMC-Asm mode."
 624   '("LMC-Asm"
 625     ["Assemble" lmc-asm-assemble]
 626     ["Load into Simulator" lmc-asm-load]))
 627
 628
 629 (defconst lmc-asm-mnemonic-names
 630   (mapcar #'symbol-name
 631           (append (mapcar #'car lmc-mnemonic-1-table)
 632                   (mapcar #'car lmc-mnemonic-0-table)
 633                   '(DAT))))
 634
 635 (defconst lmc-asm-mnemonic-names-re (regexp-opt lmc-asm-mnemonic-names))
 636
 637 (defvar lmc-asm-font-lock-keywords
 638   `(("^[ \t]*\\(?:\\sw\\|\\s_\\)+"
 639      (0 (if (zerop (nth 0 (syntax-ppss))) font-lock-constant-face)))
 640     (,(concat "(\\(" lmc-asm-mnemonic-names-re "\\_>\\)")
 641      (1 font-lock-keyword-face))))
 642
 643 (defvar lmc-asm-imenu-generic-expression
 644   '((nil "^\\(\\(?:\\sw\\|\\s_\\)+\\)" 1)))
 645
 646 (defvar lmc-asm-outline-regexp "^\\(?:\\sw\\|\\s_\\)")
 647
 648 ;; We use the ".elmc" extension since the syntax is not identical to
 649 ;; the usual ".lmc" syntax.
 650 ;;;###autoload
 651 (add-to-list 'auto-mode-alist '("\\.elmc\\'" . lmc-asm-mode))
 652
 653 ;;;###autoload
 654 (define-derived-mode lmc-asm-mode fundamental-mode "LMC-Asm"
 655   "Major mode to edit LMC assembly code."
 656   :syntax-table emacs-lisp-mode-syntax-table
 657   (set (make-local-variable 'font-lock-defaults)
 658        '(lmc-asm-font-lock-keywords))
 659   (set (make-local-variable 'indent-line-function)
 660        #'lmc-asm-indent-line)
 661   (set (make-local-variable 'indent-tabs-mode) t)
 662   (set (make-local-variable 'imenu-generic-expression)
 663        lmc-asm-imenu-generic-expression)
 664   (set (make-local-variable 'outline-regexp) lmc-asm-outline-regexp)
 665   (add-hook 'completion-at-point-functions #'lmc-asm-completion nil t)
 666   (set (make-local-variable 'comment-start) ";")
 667   (set (make-local-variable 'comment-start-skip)
 668        "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
 669   )
 670
 671 (defun lmc-asm-labels (string)
 672   (save-excursion
 673     ;; We don't want to count the label being completed as a completion
 674     ;; candidate, so let's keep track of the original position of point and
 675     ;; skip any label nearby.
 676     (let ((point (point)))
 677       (goto-char (point-min))
 678       (let ((ls ())
 679             (re (concat "\\(^\\|(" lmc-asm-mnemonic-names-re "[ \t]+" "\\)"
 680                         (regexp-quote string) "\\(?:\\sw\\|\\s_\\)"
 681                         (if (> (length string) 0) "*" "+"))))
 682         (while (re-search-forward re nil t)
 683           (when (or (< point (match-end 1))
 684                     (> (match-beginning 1) point))
 685             (push (buffer-substring-no-properties
 686                    (match-end 1) (match-end 0)) ls)))
 687         ls))))
 688
 689 (defun lmc-asm-completion ()
 690   (save-excursion
 691     (let ((ppss (syntax-ppss)))
 692       (cond
 693        ((nth 8 ppss) nil)               ;Inside string or comment.
 694        ((zerop (nth 0 ppss))
 695         (skip-syntax-backward "w_")
 696         (when (save-excursion (skip-chars-backward " \t") (bolp))
 697           (list (point)
 698                 (save-excursion (skip-syntax-forward "w_") (point))
 699                 (completion-table-dynamic #'lmc-asm-labels))))
 700        ((= 1 (nth 0 ppss))              ;Inside paren.
 701         (skip-syntax-backward "w_")
 702         (list (point)
 703               (save-excursion (skip-syntax-forward "w_") (point))
 704               (if (eq (char-before) ?\()
 705                   lmc-asm-mnemonic-names
 706                 (completion-table-dynamic #'lmc-asm-labels))))))))
 707
 708 (defun lmc-asm-indentation ()
 709   (save-excursion
 710     (back-to-indentation)
 711     (cond
 712      ((> (nth 0 (syntax-ppss)) 0) nil)
 713      ((looking-at "(") tab-width)
 714      ((not (looking-at comment-start-skip))
 715       (if (looking-at "[ \t]*$") tab-width 0))
 716      ((not (looking-at "\\s<\\s<")) nil)
 717      ((save-excursion (forward-comment (- (point))) (bobp)) 0)
 718      (t (forward-comment (point-max)) (lmc-asm-indentation)))))
 719
 720 (defun lmc-asm-indent-line (&optional arg)
 721   (save-excursion
 722     (back-to-indentation)
 723     (when (and (zerop (nth 0 (syntax-ppss)))
 724                (looking-at (concat lmc-asm-mnemonic-names-re "\\_>")))
 725       ;; Apparently the user forgot to parenthesize the instruction.
 726       (insert "(")
 727       (if (assq (read (current-buffer)) lmc-mnemonic-0-table)
 728           (insert ")")
 729         (let ((eol (line-end-position)))
 730           (ignore-errors
 731             (read (current-buffer))
 732             (when (<= (point) eol)
 733               (insert ")")))))))
 734   (let ((indent (lmc-asm-indentation)))
 735     (cond
 736      ((null indent) (lisp-indent-line arg))
 737      (t
 738       (let ((left-margin indent)) (indent-to-left-margin))
 739       (when (zerop indent)
 740         ;; Indent code (if any) after a label.
 741         (save-excursion
 742           (beginning-of-line)
 743           (when (looking-at "\\(?:\\sw\\|\\s_\\)+\\([ \t]*\\)(")
 744             (goto-char (match-beginning 1))
 745             (if (< (current-column) tab-width)
 746                 (unless (save-excursion
 747                           (goto-char (match-end 1))
 748                           (= (current-column) tab-width))
 749                   (delete-region (match-beginning 1) (match-end 1))
 750                   (indent-to tab-width))
 751               (unless (equal (match-string 1) " ")
 752                 (delete-region (match-beginning 1) (match-end 1))
 753                 (insert " "))))))))))
 754
 755 (defun lmc-asm-read ()
 756   (let ((prog ())
 757         (initialpos (point)))
 758     (goto-char (point-min))
 759     (while (progn (forward-comment (point-max))
 760                   (not (eobp)))
 761       (let ((start (point)))
 762         (condition-case nil
 763             (push (cons (point) (read (current-buffer))) prog)
 764           (end-of-file (goto-char start) (signal 'end-of-file nil)))))
 765     (goto-char initialpos)
 766     (nreverse prog)))
 767
 768 (defun lmc-asm-load ()
 769   "Load current buffer into the LMC simulator."
 770   (interactive)
 771   (let ((initialpos (point))
 772         (window (if (eq (current-buffer) (window-buffer)) (selected-window))))
 773     (save-current-buffer
 774       (lmc-load (lmc--assemble (lmc-asm-read))))
 775     (goto-char initialpos)
 776     (if (and window (eq (current-buffer) (window-buffer window)))
 777         (set-window-point window (point)))))
 778
 779 (defun lmc-asm-assemble ()
 780   "Assemble current buffer to check syntax."
 781   (interactive)
 782   (let ((initialpos (point)))
 783     (lmc--assemble (lmc-asm-read))
 784     (goto-char initialpos)
 785     (message "No errors found")))
 786
 787 (defun lmc-load-file (file)
 788   "Load FILE into the LMC simulator."
 789   (interactive
 790    (list (read-file-name "Load LMC file: " nil nil t nil
 791                          (lambda (file)
 792                            (or (file-directory-p file)
 793                                (string-match-p "\\.elmc\\'" file))))))
 794   (let ((exists (find-buffer-visiting file))
 795         (buf (find-file-noselect file)))
 796     (unwind-protect
 797         (with-current-buffer buf
 798           (condition-case err
 799               (lmc-asm-load)
 800             (error (error "Error at line %d: %s" (line-number-at-pos)
 801                           (error-message-string err)))))
 802       (unless exists (kill-buffer buf)))))
 803
 804 (provide 'lmc)
 805 ;;; lmc.el ends here