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

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