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