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

   1 ;;; lmc.el --- Little Man Computer in Elisp  -*- lexical-binding:t -*-
   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)) (base (current-column)))
 212       (if (and label (symbolp label))
 213           (insert (symbol-name label)))
 214       ;; (when (>= (current-column) (+ base tab-width))
 215       ;;   (while (>= (current-column) (+ base tab-width -1))
 216       ;;     (delete-char -1))
 217       ;;   (insert "…")
 218       ;;   (put-text-property basepos (point)
 219       ;;                      'help-echo (symbol-name label)))
 220       ;; (insert (propertize
 221       ;;      (make-string (1+ (- lmc-label-width (current-column))) ?\s)
 222       ;;      'display '(space :align-to (1+ lmc-label-width))))
 223       (insert (eval-when-compile (propertize "\t"
 224                                              'read-only t
 225                                              'rear-nonsticky t))))
 226     (insert (format "  %03d" word))
 227     (insert (if code
 228                 (eval-when-compile (propertize "\n"
 229                                                'lmc-code t
 230                                                'read-only t
 231                                                'rear-nonsticky t))
 232               (eval-when-compile (propertize "\n"
 233                                              'read-only t
 234                                              'rear-nonsticky t))))))
 235
 236 (defun lmc-disassemble-word (word)
 237   (let ((code (car (rassq (/ word 100) lmc-mnemonic-1-table))))
 238     (cond
 239      (code (list code (mod word 100)))
 240      ((rassq word lmc-mnemonic-0-table)
 241       (list (car (rassq word lmc-mnemonic-0-table)))))))
 242
 243 (defun lmc-addr->point (addr)
 244   (goto-char (point-min))
 245   (forward-line addr))
 246
 247 (defun lmc-point->addr ()
 248   (- (count-lines (point-min) (point)) (if (bolp) 0 1)))
 249
 250 (defun lmc-get-word (&optional addr fix)
 251   (save-excursion
 252     (if (null addr)
 253         (forward-line 0)
 254       (lmc-addr->point addr))
 255     (cond
 256      ((re-search-forward "\t.*\t  \\([0-9][0-9][0-9]\\)$"
 257                          (line-end-position) t)
 258       (string-to-number (match-string 1)))
 259      ((re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t)
 260       (let ((n (string-to-number (match-string 1))))
 261         (unless (integerp n) (setq n (truncate n)))
 262         (setq n (mod n 1000))
 263         (when fix
 264           (replace-match (format "  %03d" n) t t nil 1))
 265         n))
 266      (t 0))))
 267
 268 (defconst lmc-label-re "^\\([^\t\n]*\\)\t\\(.*\\)\t *[0-9]")
 269
 270 (defvar lmc-label-table nil)
 271
 272 (defun lmc-record-label (addr label)
 273   (let ((old (aref lmc-label-table addr)))
 274     (unless (and old (equal (car old) label))
 275       ;; (message "recordlabel %S = %S" addr label)
 276       (aset lmc-label-table addr (list label))
 277       (when (cdr old)
 278         (run-with-timer
 279          0 nil
 280          (lambda (buf refaddrs)
 281            (with-current-buffer buf
 282              (save-excursion
 283                ;; (message "refreshlabel in %S" refaddrs)
 284                (dolist (refaddr refaddrs)
 285                  (lmc-addr->point (1+ refaddr))
 286                  (unless (bobp)
 287                    (let ((inhibit-read-only t))
 288                      (put-text-property (1- (point)) (point)
 289                                         'fontified nil)))))))
 290          (current-buffer) (cdr old))))))
 291
 292 (defun lmc-get-label (addr)
 293   (save-excursion
 294     ;; (if (null addr)
 295     ;;     (forward-line 0)
 296     (lmc-addr->point addr) ;; )
 297     (let ((label (when (re-search-forward lmc-label-re nil t)
 298                    (if (> (match-end 2) (match-beginning 2))
 299                        (match-string 2)))))
 300       (lmc-record-label addr label)
 301       label)))
 302
 303
 304 (defun lmc-font-lock-opcode ()
 305   (save-match-data
 306     (when (get-text-property (line-end-position) 'lmc-code)
 307       (let* ((word (lmc-get-word))
 308              (code (lmc-disassemble-word word)))
 309         ;; Resolve labels.
 310         (when (integerp (nth 1 code))
 311           (let* ((addr (nth 1 code))
 312                  (label (lmc-get-label addr)))
 313             (pushnew (lmc-point->addr)
 314                      (cdr (aref lmc-label-table addr)))
 315             (when label
 316               (setf (nth 1 code) label))))
 317         (put-text-property
 318          (line-end-position) (1+ (line-end-position))
 319          'display
 320          (format (eval-when-compile
 321                    (concat (propertize "\t" 'cursor t)
 322                            (propertize "%s" 'face font-lock-comment-face)
 323                            "\n"))
 324                  (or code '(Invalid opcode)))))
 325       nil)))
 326
 327 (defun lmc-font-lock-label ()
 328   (lmc-record-label (lmc-point->addr)
 329                     (if (> (match-end 2) (match-beginning 2))
 330                        (match-string 2)))
 331   (save-excursion
 332     ;; ;; Replace any TAB found in label.
 333     ;; (goto-char (match-beginning 2))
 334     ;; (while (progn (skip-chars-forward "^\t" (match-end 2))
 335     ;;               (< (point) (match-end 2)))
 336     ;;   (insert " ") (delete-char 1))
 337     ;; Truncate label's display if needed.
 338     (move-to-column (1- (* 2 tab-width)))
 339     (when (> (match-end 2) (point))
 340       (forward-char -1)
 341       (put-text-property (match-beginning 2) (match-end 2)
 342                          'help-echo (match-string 2))
 343       (put-text-property (point) (match-end 2) 'display "…")))
 344   font-lock-constant-face)
 345
 346 (defconst lmc-font-lock-keywords
 347   `((,lmc-label-re
 348      (1 'hexl-address-region)
 349      (2 (lmc-font-lock-label)))
 350     (".$" (0 (lmc-font-lock-opcode)))))
 351
 352 (defun lmc-after-change (beg end _len)
 353   (unless inhibit-read-only
 354     (save-excursion
 355       ;; Replace any TAB or NL inserted, which could interfere with parsing.
 356       (goto-char beg)
 357       (while (progn (skip-chars-forward "^\t\n" end)
 358                     (< (point) end))
 359         (insert " ") (delete-char 1)))))
 360
 361 (defvar lmc-pc 0 "LMC program counter.")
 362 (make-variable-buffer-local 'lmc-pc)
 363 (defvar lmc-acc nil "LMC accumulator.")
 364 (make-variable-buffer-local 'lmc-acc)
 365 (defvar lmc-output nil "Past LMC output.")
 366 (make-variable-buffer-local 'lmc-output)
 367
 368 (defvar lmc--stopped nil "State where we stopped.")
 369 (make-variable-buffer-local 'lmc--stopped)
 370
 371 (defun lmc-update-pc ()
 372   (setq lmc-pc (mod lmc-pc 100))
 373   (lmc-addr->point lmc-pc)
 374   (move-marker overlay-arrow-position (point))
 375   (re-search-forward "\t.*\t *" nil t)
 376   (unless (get-text-property (line-end-position) 'lmc-code)
 377     (let ((inhibit-read-only t))
 378       (put-text-property (line-end-position)
 379                          (min (1+ (line-end-position)) (point-max))
 380                          'lmc-code t))))
 381
 382 (defun lmc--state ()
 383   (list (buffer-chars-modified-tick) lmc-acc lmc-pc))
 384 (defun lmc-stopped-p ()
 385   (equal (lmc--state) lmc--stopped))
 386
 387 ;; FIXME: Add tool-bar to LMC-Sim.
 388
 389 (defvar lmc-mode-map
 390   (let ((map (make-sparse-keymap)))
 391     (define-key map "\C-c\C-s" 'lmc-step)
 392     (define-key map "\C-c\C-r" 'lmc-run)
 393     (define-key map "\C-c\C-l" 'lmc-load-file)
 394     (define-key map "\C-c\C-a" 'lmc-set-acc)
 395     (define-key map "\C-c\C-p" 'lmc-set-pc)
 396     map))
 397
 398 (easy-menu-define lmc-menu lmc-mode-map "Menu for LMC-Sim."
 399   '("LMC-Sim"
 400     ["Step" lmc-step (not (lmc-stopped-p))]
 401     ["Run" lmc-run (not (lmc-stopped-p))]
 402     ["Load file" lmc-load-file]
 403     "--"
 404     ["Set Program Counter" lmc-set-pc]
 405     ["Set Accumulator" lmc-set-acc]))
 406
 407 (defvar lmc-tool-bar-map
 408   (let ((map (make-sparse-keymap)))
 409     (tool-bar-local-item "gud/next" 'lmc-step 'step map
 410                          :label "Step" ;; :vert-only t
 411                          :enable '(not (lmc-stopped-p))
 412                          )
 413     (tool-bar-local-item "gud/run" 'lmc-run 'run map
 414                          :label "Run" ;; :vert-only t
 415                          :enable '(not (lmc-stopped-p))
 416                          )
 417     map))
 418
 419 (defun lmc-tool-bar-to-string (&optional map)
 420   (let ((res ""))
 421     (map-keymap
 422      (lambda (_k v)
 423        (when (eq (car v) 'menu-item)
 424          (let* ((label (nth 1 v))
 425                 (cmd (nth 2 v))
 426                 (plist (nthcdr (if (consp (nth 3 v)) 4 3) v))
 427                 (help-echo (plist-get plist :help))
 428                 (image     (plist-get plist :image))
 429                 (enable-exp (if (plist-member plist :enable)
 430                                 (plist-get plist :enable)
 431                               t))
 432                 (enable (eval enable-exp))
 433                 (map (let ((map (make-sparse-keymap)))
 434                        (define-key map [header-line mouse-1] cmd)
 435                        (define-key map [header-line mouse-2] cmd)
 436                        map))
 437                 (button
 438                  (propertize " " 'help-echo (or help-echo label)
 439                              'keymap map
 440                              'face 'header-line
 441                              'mouse-face (if enable 'mode-line-highlight)
 442                              'rear-nonsticky '(display keymap help-echo)
 443                              'display (if (and (eq 'image (car image))
 444                                                (not enable))
 445                                           `(image :conversion disabled
 446                                                   ,@(cdr image))
 447                                         image))))
 448            (setq res (concat res (propertize " " 'display '(space :width 0.5)
 449                                              'face 'header-line
 450                                              )
 451                              button)))))
 452      (or (let ((tool-bar-map map)) (tool-bar-make-keymap))
 453          (key-binding [tool-bar])))
 454     res))
 455
 456 (define-derived-mode lmc-mode fundamental-mode "LMC-Sim"
 457   "The simulator of the Little Man Computer."
 458   (set (make-local-variable 'truncate-lines) t)
 459   (set (make-local-variable 'truncate-partial-width-windows) t)
 460   (set (make-local-variable 'tab-width) 10)
 461   (set (make-local-variable 'font-lock-defaults)
 462        '(lmc-font-lock-keywords t))
 463   (set (make-local-variable 'font-lock-extra-managed-props)
 464        '(display help-echo))
 465   ;; (set (make-local-variable 'tool-bar-map) lmc-tool-bar-map)
 466   (add-hook 'after-change-functions #'lmc-after-change nil t)
 467   (set (make-local-variable 'lmc-label-table) (make-vector 100 nil))
 468   (set (make-local-variable 'overlay-arrow-position) (point-min-marker))
 469   (lmc-update-pc)
 470   ;; (overwrite-mode 1)
 471   (set (make-local-variable 'header-line-format)
 472        `(""
 473          (:eval (lmc-tool-bar-to-string lmc-tool-bar-map))
 474          "  " ,(propertize "LMC-Sim" 'face '(bold italic)) "  "
 475          ,(propertize "PC=" 'face 'font-lock-function-name-face)
 476          (:eval (format ,(propertize "%02d"
 477                                      'mouse-face 'mode-line-highlight
 478                                      'help-echo
 479                                      "mouse-2: set the Program Counter"
 480                                      'follow-link t
 481                                      ;; I'm having problems with mouse-2 to
 482                                      ;; mouse-1 remapping in the mode-line and
 483                                      ;; header-line, so I over-do it a bit.
 484                                      'keymap
 485                                      '(keymap
 486                                        (header-line keymap
 487                                                     (down-mouse-1 . ignore)
 488                                                     (mouse-2 . lmc-set-pc)
 489                                                     (mouse-1 . lmc-set-pc))))
 490                         lmc-pc))
 491          "  " ,(propertize "ACC=" 'face 'font-lock-function-name-face)
 492          (:eval (format ,(propertize "%03d"
 493                                      'mouse-face 'mode-line-highlight
 494                                      'help-echo "mouse-2: set the Accumulator"
 495                                      'follow-link t
 496                                      'keymap
 497                                      ;; I'm having problems with mouse-2 to
 498                                      ;; mouse-1 remapping in the mode-line and
 499                                      ;; header-line, so I over-do it a bit.
 500                                      '(keymap
 501                                        (header-line keymap
 502                                                     (down-mouse-1 . ignore)
 503                                                     (mouse-2 . lmc-set-acc)
 504                                                     (mouse-1 . lmc-set-acc))))
 505                         lmc-acc))
 506          "      " ,(propertize "Recent output="
 507                                'face 'font-lock-function-name-face)
 508          (:eval (if lmc-output (format "%s" lmc-output) "()"))))
 509   )
 510
 511 (defun lmc-set-pc (pc)
 512   "Set the Program Counter."
 513   (interactive (list (read-number "New PC: " lmc-pc)))
 514   (setq lmc-pc pc)
 515   (lmc-update-pc))
 516
 517 (defun lmc-set-acc (acc)
 518   "Set the Accumulator."
 519   (interactive (list (read-number "New Accumulator: " lmc-acc)))
 520   (setq lmc-acc (mod acc 1000)))
 521
 522 (defun lmc-load (words)
 523   (pop-to-buffer "*LMC-Sim*")
 524   (lmc-mode)
 525   (let ((inhibit-read-only t)
 526         (addr 0))
 527     (setq lmc-pc 0)
 528     (setq lmc-acc 0)
 529     (setq lmc-output nil)
 530     (erase-buffer)
 531     (dolist (word words)
 532       (lmc--load-word word addr)
 533       (setq addr (1+ addr)))
 534     (while (< addr 100)
 535       (lmc--load-word '(0) addr)
 536       (setq addr (1+ addr))))
 537   (lmc-update-pc))
 538
 539 (defcustom lmc-store-flash t
 540   "If non-nil, memory words blink when modified."
 541   :type 'boolean)
 542
 543 (defun lmc--sit-for (secs)
 544   (unless lmc-turbo (sit-for secs)))
 545
 546 (defun lmc-store-word (addr word)
 547   (save-excursion
 548     (lmc-addr->point addr)
 549     (if (not (re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t))
 550         (error "Missing memory cell %S" addr)
 551       (let ((mb1 (match-beginning 1)))
 552         (when lmc-store-flash
 553           (lmc--with-silent-modifications
 554            (put-text-property mb1 (point) 'face 'region))
 555           (lmc--sit-for 0.2))
 556         (let ((me1 (point)))
 557           (insert (format "  %03d" word)) (delete-region mb1 me1))
 558         (when lmc-store-flash
 559           (lmc--sit-for 0.1)
 560           (lmc--with-silent-modifications
 561            (put-text-property mb1 (point) 'face 'region))
 562           (lmc--sit-for 0.1)
 563           (lmc--with-silent-modifications
 564            (put-text-property mb1 (point) 'face nil))
 565           (lmc--sit-for 0.1))))))
 566
 567 (defun lmc-step ()
 568   "Execute one LMC instruction."
 569   (interactive)
 570   (let* ((inst (lmc-get-word lmc-pc 'fix))
 571          (code (lmc-disassemble-word inst)))
 572     (case (car code)
 573       (HLT (if (lmc-stopped-p)
 574                (error "Already halted")
 575              (setq lmc--stopped (lmc--state))
 576              (force-mode-line-update)
 577              (message "Done.")))
 578       (IN (setq lmc-acc (mod (read-number "Enter a number: ") 1000))
 579           (incf lmc-pc))
 580       (OUT (message "Output: %03d" lmc-acc)
 581            (push (format "%03d" lmc-acc) lmc-output)
 582            (incf lmc-pc))
 583       (LDA (setq lmc-acc (lmc-get-word (nth 1 code)))
 584            (incf lmc-pc))
 585       (STO (lmc-store-word (nth 1 code) lmc-acc)
 586            (incf lmc-pc))
 587       (ADD (setq lmc-acc (mod (+ lmc-acc (lmc-get-word (nth 1 code)))
 588                               1000))
 589            (incf lmc-pc))
 590       (SUB (setq lmc-acc (mod (- lmc-acc (lmc-get-word (nth 1 code)))
 591                               1000))
 592            (incf lmc-pc))
 593       (BR (setq lmc-pc (nth 1 code)))
 594       (BRZ (setq lmc-pc (if (zerop lmc-acc)
 595                             (nth 1 code)
 596                           (1+ lmc-pc))))
 597       (BRP (setq lmc-pc (if (< lmc-acc 500)
 598                             (nth 1 code)
 599                           (1+ lmc-pc))))
 600       ((nil) (error "Invalid instruction %S" inst))
 601       (t (error "%S not implemented" code))))
 602   (lmc-update-pc))
 603
 604 (defun lmc-run ()
 605   "Run the code until hitting a HLT.
 606 The machine will also stop if the user presses a key."
 607   (interactive)
 608   (while (not (or (unless lmc-turbo (input-pending-p)) (lmc-stopped-p)))
 609     (lmc-step)
 610     (lmc--sit-for 0.05)))
 611
 612 ;;; The LMC assembly language editor.
 613
 614 (defvar lmc-asm-mode-map
 615   (let ((map (make-sparse-keymap)))
 616     ;; FIXME: Add "load" and "assemble" buttons.
 617     (define-key map "\C-c\C-l" 'lmc-asm-load)
 618     (define-key map "\C-c\C-a" 'lmc-asm-assemble)
 619     map))
 620
 621 (easy-menu-define lmc-asm-menu lmc-asm-mode-map
 622   "Menu for the LMC-Asm mode."
 623   '("LMC-Asm"
 624     ["Assemble" lmc-asm-assemble]
 625     ["Load into Simulator" lmc-asm-load]))
 626
 627
 628 (defconst lmc-asm-mnemonic-names
 629   (mapcar #'symbol-name
 630           (append (mapcar #'car lmc-mnemonic-1-table)
 631                   (mapcar #'car lmc-mnemonic-0-table)
 632                   '(DAT))))
 633
 634 (defconst lmc-asm-mnemonic-names-re (regexp-opt lmc-asm-mnemonic-names))
 635
 636 (defvar lmc-asm-font-lock-keywords
 637   `(("^[ \t]*\\(?:\\sw\\|\\s_\\)+"
 638      (0 (if (zerop (nth 0 (syntax-ppss))) font-lock-constant-face)))
 639     (,(concat "(\\(" lmc-asm-mnemonic-names-re "\\_>\\)")
 640      (1 font-lock-keyword-face))))
 641
 642 (defvar lmc-asm-imenu-generic-expression
 643   '((nil "^\\(\\(?:\\sw\\|\\s_\\)+\\)" 1)))
 644
 645 (defvar lmc-asm-outline-regexp "^\\(?:\\sw\\|\\s_\\)")
 646
 647 ;; We use the ".elmc" extension since the syntax is not identical to
 648 ;; the usual ".lmc" syntax.
 649 ;;;###autoload
 650 (add-to-list 'auto-mode-alist '("\\.elmc\\'" . lmc-asm-mode))
 651
 652 ;;;###autoload
 653 (define-derived-mode lmc-asm-mode fundamental-mode "LMC-Asm"
 654   "Major mode to edit LMC assembly code."
 655   :syntax-table emacs-lisp-mode-syntax-table
 656   (set (make-local-variable 'font-lock-defaults)
 657        '(lmc-asm-font-lock-keywords))
 658   (set (make-local-variable 'indent-line-function)
 659        #'lmc-asm-indent-line)
 660   (set (make-local-variable 'indent-tabs-mode) t)
 661   (set (make-local-variable 'imenu-generic-expression)
 662        lmc-asm-imenu-generic-expression)
 663   (set (make-local-variable 'outline-regexp) lmc-asm-outline-regexp)
 664   (add-hook 'completion-at-point-functions #'lmc-asm-completion nil t)
 665   (set (make-local-variable 'comment-start) ";")
 666   (set (make-local-variable 'comment-start-skip)
 667        "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
 668   )
 669
 670 (defun lmc-asm-labels (string)
 671   (save-excursion
 672     ;; We don't want to count the label being completed as a completion
 673     ;; candidate, so let's keep track of the original position of point and
 674     ;; skip any label nearby.
 675     (let ((point (point)))
 676       (goto-char (point-min))
 677       (let ((ls ())
 678             (re (concat "\\(^\\|(" lmc-asm-mnemonic-names-re "[ \t]+" "\\)"
 679                         (regexp-quote string) "\\(?:\\sw\\|\\s_\\)"
 680                         (if (> (length string) 0) "*" "+"))))
 681         (while (re-search-forward re nil t)
 682           (when (or (< point (match-end 1))
 683                     (> (match-beginning 1) point))
 684             (push (buffer-substring-no-properties
 685                    (match-end 1) (match-end 0)) ls)))
 686         ls))))
 687
 688 (defun lmc-asm-completion ()
 689   (save-excursion
 690     (let ((ppss (syntax-ppss)))
 691       (cond
 692        ((nth 8 ppss) nil)               ;Inside string or comment.
 693        ((zerop (nth 0 ppss))
 694         (skip-syntax-backward "w_")
 695         (when (save-excursion (skip-chars-backward " \t") (bolp))
 696           (list (point)
 697                 (save-excursion (skip-syntax-forward "w_") (point))
 698                 (completion-table-dynamic #'lmc-asm-labels))))
 699        ((= 1 (nth 0 ppss))              ;Inside paren.
 700         (skip-syntax-backward "w_")
 701         (list (point)
 702               (save-excursion (skip-syntax-forward "w_") (point))
 703               (if (eq (char-before) ?\()
 704                   lmc-asm-mnemonic-names
 705                 (completion-table-dynamic #'lmc-asm-labels))))))))
 706
 707 (defun lmc-asm-indentation ()
 708   (save-excursion
 709     (back-to-indentation)
 710     (cond
 711      ((> (nth 0 (syntax-ppss)) 0) nil)
 712      ((looking-at "(") tab-width)
 713      ((not (looking-at comment-start-skip))
 714       (if (looking-at "[ \t]*$") tab-width 0))
 715      ((not (looking-at "\\s<\\s<")) nil)
 716      ((save-excursion (forward-comment (- (point))) (bobp)) 0)
 717      (t (forward-comment (point-max)) (lmc-asm-indentation)))))
 718
 719 (defun lmc-asm-indent-line (&optional arg)
 720   (save-excursion
 721     (back-to-indentation)
 722     (when (and (zerop (nth 0 (syntax-ppss)))
 723                (looking-at (concat lmc-asm-mnemonic-names-re "\\_>")))
 724       ;; Apparently the user forgot to parenthesize the instruction.
 725       (insert "(")
 726       (if (assq (read (current-buffer)) lmc-mnemonic-0-table)
 727           (insert ")")
 728         (let ((eol (line-end-position)))
 729           (ignore-errors
 730             (read (current-buffer))
 731             (when (<= (point) eol)
 732               (insert ")")))))))
 733   (let ((indent (lmc-asm-indentation)))
 734     (cond
 735      ((null indent) (lisp-indent-line arg))
 736      (t
 737       (let ((left-margin indent)) (indent-to-left-margin))
 738       (when (zerop indent)
 739         ;; Indent code (if any) after a label.
 740         (save-excursion
 741           (beginning-of-line)
 742           (when (looking-at "\\(?:\\sw\\|\\s_\\)+\\([ \t]*\\)(")
 743             (goto-char (match-beginning 1))
 744             (if (< (current-column) tab-width)
 745                 (unless (save-excursion
 746                           (goto-char (match-end 1))
 747                           (= (current-column) tab-width))
 748                   (delete-region (match-beginning 1) (match-end 1))
 749                   (indent-to tab-width))
 750               (unless (equal (match-string 1) " ")
 751                 (delete-region (match-beginning 1) (match-end 1))
 752                 (insert " "))))))))))
 753
 754 (defun lmc-asm-read ()
 755   (let ((prog ())
 756         (initialpos (point)))
 757     (goto-char (point-min))
 758     (while (progn (forward-comment (point-max))
 759                   (not (eobp)))
 760       (let ((start (point)))
 761         (condition-case nil
 762             (push (cons (point) (read (current-buffer))) prog)
 763           (end-of-file (goto-char start) (signal 'end-of-file nil)))))
 764     (goto-char initialpos)
 765     (nreverse prog)))
 766
 767 (defun lmc-asm-load ()
 768   "Load current buffer into the LMC simulator."
 769   (interactive)
 770   (let ((initialpos (point))
 771         (window (if (eq (current-buffer) (window-buffer)) (selected-window))))
 772     (save-current-buffer
 773       (lmc-load (lmc--assemble (lmc-asm-read))))
 774     (goto-char initialpos)
 775     (if (and window (eq (current-buffer) (window-buffer window)))
 776         (set-window-point window (point)))))
 777
 778 (defun lmc-asm-assemble ()
 779   "Assemble current buffer to check syntax."
 780   (interactive)
 781   (let ((initialpos (point)))
 782     (lmc--assemble (lmc-asm-read))
 783     (goto-char initialpos)
 784     (message "No errors found")))
 785
 786 (defun lmc-load-file (file)
 787   "Load FILE into the LMC simulator."
 788   (interactive
 789    (list (read-file-name "Load LMC file: " nil nil t nil
 790                          (lambda (file)
 791                            (or (file-directory-p file)
 792                                (string-match-p "\\.elmc\\'" file))))))
 793   (let ((exists (find-buffer-visiting file))
 794         (buf (find-file-noselect file)))
 795     (unwind-protect
 796         (with-current-buffer buf
 797           (condition-case err
 798               (lmc-asm-load)
 799             (error (error "Error at line %d: %s" (line-number-at-pos)
 800                           (error-message-string err)))))
 801       (unless exists (kill-buffer buf)))))
 802
 803 (provide 'lmc)
 804 ;;; lmc.el ends here