1 ;;; lmc.el --- Little Man Computer in Elisp -*- lexical-binding:t -*-
3 ;; Copyright (C) 2011, 2013, 2014 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
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.
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.
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/>.
23 ;; A simulator for the Little Man Computer.
24 ;; http://en.wikipedia.org/wiki/Little_man_computer
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".
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.
41 ;; So the assembly (stored in files with extension ".elmc") looks like:
44 ;; (BR label2) ;Useless extra jump.
46 ;; (LDA data1) ;Cleverest part of the algorithm.
52 ;; data2 (DAT 050 060 070)
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.
58 ;; The lmc-asm-mode supports the usual editing features such as label
59 ;; completion, mnemonic completion, jumping to a label, automatic indentation,
64 (eval-when-compile (require 'cl))
68 "Customization group for the Little Man Computer simulator."
73 (defvar lmc--pc 0 "Program counter for LMC.")
74 (make-variable-buffer-local 'lmc--pc)
76 (defvar lmc-acc 0 "Accumulator for LMC.")
77 (make-variable-buffer-local 'lmc--acc)
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.")
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))
94 (inhibit-modification-hooks t)
96 ;; Avoid setting and removing file locks and checking
97 ;; buffer's uptodate-ness w.r.t the underlying file.
104 (restore-buffer-modified-p nil)))))))
106 ;; (defun lmc-check (cmds)
107 ;; (dolist (cmd cmds)
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)))))
115 (defun lmc--numberp (n max)
117 (or (and (or (natnump n) (error "%S is not a positive integer" n))
118 (or (< n max) (error "%S is too large" n))))))
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)
125 "Arg %S is neither a label nor a number")
128 (defconst lmc-mnemonic-1-table '((LDA . 5)
135 "Mnemonic table for arity-1 instructions.")
137 (defconst lmc-mnemonic-0-table '((HLT . 000) (COB . 000)
138 (IN . 901) (INP . 901)
140 "Mnemonic table for arity-0 instructions.")
142 (defun lmc--assemble (cmds)
143 ;; FIXME: Move to error position upon error.
146 ;; First pass, resolve labels to their positions.
148 (setq cmd (cdr cmd)) ;Ignore position info at this stage.
151 (assq cmd lmc-mnemonic-0-table))
152 (setq pos (+ pos (if (eq (car cmd) 'DAT)
153 (1- (length cmd)) 1))))
156 ((not (and (natnump cmd) (< cmd 100)))
157 (error "%S is not a valid address" cmd))
159 (error "Address %S already used" cmd))
161 (error "Label %S needs to come after address %S"
162 (car (rassq pos labels)) 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.
173 (lambda (w &optional code)
174 (push (list w ll code) words) (setq ll nil))))
176 (goto-char (pop cmd)) ;Move to start of CMD, in case of error.
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)
188 (+ (* 100 (cdr (assq (car cmd) lmc-mnemonic-1-table)))
189 (lmc--resolve (nth 1 cmd) labels 100))
192 (dotimes (_ (- cmd (length words)))
193 (funcall newword 0)))
194 ((and cmd (symbolp cmd))
195 (assert (eq (cdr (assq cmd labels)) (length words)))
197 (t (error "Invalid instruction %S" cmd))))
200 ;; (defvar lmc-label-width 8)
202 (defun lmc--load-word (word addr)
204 (insert (propertize (format " %02d:\t" addr)
208 (let ((word (car 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))
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"
225 'rear-nonsticky t))))
226 (insert (format " %03d" word))
228 (eval-when-compile (propertize "\n"
232 (eval-when-compile (propertize "\n"
234 'rear-nonsticky t))))))
236 (defun lmc-disassemble-word (word)
237 (let ((code (car (rassq (/ word 100) lmc-mnemonic-1-table))))
239 (code (list code (mod word 100)))
240 ((rassq word lmc-mnemonic-0-table)
241 (list (car (rassq word lmc-mnemonic-0-table)))))))
243 (defun lmc-addr->point (addr)
244 (goto-char (point-min))
247 (defun lmc-point->addr ()
248 (- (count-lines (point-min) (point)) (if (bolp) 0 1)))
250 (defun lmc-get-word (&optional addr fix)
254 (lmc-addr->point addr))
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))
264 (replace-match (format " %03d" n) t t nil 1))
268 (defconst lmc-label-re "^\\([^\t\n]*\\)\t\\(.*\\)\t *[0-9]")
270 (defvar lmc-label-table nil)
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))
280 (lambda (buf refaddrs)
281 (with-current-buffer buf
283 ;; (message "refreshlabel in %S" refaddrs)
284 (dolist (refaddr refaddrs)
285 (lmc-addr->point (1+ refaddr))
287 (let ((inhibit-read-only t))
288 (put-text-property (1- (point)) (point)
289 'fontified nil)))))))
290 (current-buffer) (cdr old))))))
292 (defun lmc-get-label (addr)
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))
300 (lmc-record-label addr label)
304 (defun lmc-font-lock-opcode ()
306 (when (get-text-property (line-end-position) 'lmc-code)
307 (let* ((word (lmc-get-word))
308 (code (lmc-disassemble-word word)))
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)))
316 (setf (nth 1 code) label))))
318 (line-end-position) (1+ (line-end-position))
320 (format (eval-when-compile
321 (concat (propertize "\t" 'cursor t)
322 (propertize "%s" 'face font-lock-comment-face)
324 (or code '(Invalid opcode)))))
327 (defun lmc-font-lock-label ()
328 (lmc-record-label (lmc-point->addr)
329 (if (> (match-end 2) (match-beginning 2))
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))
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)
346 (defconst lmc-font-lock-keywords
348 (1 'hexl-address-region)
349 (2 (lmc-font-lock-label)))
350 (".$" (0 (lmc-font-lock-opcode)))))
352 (defun lmc-after-change (beg end _len)
353 (unless inhibit-read-only
355 ;; Replace any TAB or NL inserted, which could interfere with parsing.
357 (while (progn (skip-chars-forward "^\t\n" end)
359 (insert " ") (delete-char 1)))))
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)
368 (defvar lmc--stopped nil "State where we stopped.")
369 (make-variable-buffer-local 'lmc--stopped)
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))
383 (list (buffer-chars-modified-tick) lmc-acc lmc-pc))
384 (defun lmc-stopped-p ()
385 (equal (lmc--state) lmc--stopped))
387 ;; FIXME: Add tool-bar to LMC-Sim.
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)
398 (easy-menu-define lmc-menu lmc-mode-map "Menu for LMC-Sim."
400 ["Step" lmc-step (not (lmc-stopped-p))]
401 ["Run" lmc-run (not (lmc-stopped-p))]
402 ["Load file" lmc-load-file]
404 ["Set Program Counter" lmc-set-pc]
405 ["Set Accumulator" lmc-set-acc]))
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))
413 (tool-bar-local-item "gud/run" 'lmc-run 'run map
414 :label "Run" ;; :vert-only t
415 :enable '(not (lmc-stopped-p))
419 (defun lmc-tool-bar-to-string (&optional map)
423 (when (eq (car v) 'menu-item)
424 (let* ((label (nth 1 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)
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)
438 (propertize " " 'help-echo (or help-echo label)
441 'mouse-face (if enable 'mode-line-highlight)
442 'rear-nonsticky '(display keymap help-echo)
443 'display (if (and (eq 'image (car image))
445 `(image :conversion disabled
448 (setq res (concat res (propertize " " 'display '(space :width 0.5)
452 (or (let ((tool-bar-map map)) (tool-bar-make-keymap))
453 (key-binding [tool-bar])))
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))
470 ;; (overwrite-mode 1)
471 (set (make-local-variable 'header-line-format)
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
479 "mouse-2: set the Program Counter"
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.
487 (down-mouse-1 . ignore)
488 (mouse-2 . lmc-set-pc)
489 (mouse-1 . lmc-set-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"
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.
502 (down-mouse-1 . ignore)
503 (mouse-2 . lmc-set-acc)
504 (mouse-1 . lmc-set-acc))))
506 " " ,(propertize "Recent output="
507 'face 'font-lock-function-name-face)
508 (:eval (if lmc-output (format "%s" lmc-output) "()"))))
511 (defun lmc-set-pc (pc)
512 "Set the Program Counter."
513 (interactive (list (read-number "New PC: " lmc-pc)))
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)))
522 (defun lmc-load (words)
523 (pop-to-buffer "*LMC-Sim*")
525 (let ((inhibit-read-only t)
529 (setq lmc-output nil)
532 (lmc--load-word word addr)
533 (setq addr (1+ addr)))
535 (lmc--load-word '(0) addr)
536 (setq addr (1+ addr))))
539 (defcustom lmc-store-flash t
540 "If non-nil, memory words blink when modified."
543 (defun lmc--sit-for (secs)
544 (unless lmc-turbo (sit-for secs)))
546 (defun lmc-store-word (addr word)
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))
557 (insert (format " %03d" word)) (delete-region mb1 me1))
558 (when lmc-store-flash
560 (lmc--with-silent-modifications
561 (put-text-property mb1 (point) 'face 'region))
563 (lmc--with-silent-modifications
564 (put-text-property mb1 (point) 'face nil))
565 (lmc--sit-for 0.1))))))
568 "Execute one LMC instruction."
570 (let* ((inst (lmc-get-word lmc-pc 'fix))
571 (code (lmc-disassemble-word inst)))
573 (HLT (if (lmc-stopped-p)
574 (error "Already halted")
575 (setq lmc--stopped (lmc--state))
576 (force-mode-line-update)
578 (IN (setq lmc-acc (mod (read-number "Enter a number: ") 1000))
580 (OUT (message "Output: %03d" lmc-acc)
581 (push (format "%03d" lmc-acc) lmc-output)
583 (LDA (setq lmc-acc (lmc-get-word (nth 1 code)))
585 (STO (lmc-store-word (nth 1 code) lmc-acc)
587 (ADD (setq lmc-acc (mod (+ lmc-acc (lmc-get-word (nth 1 code)))
590 (SUB (setq lmc-acc (mod (- lmc-acc (lmc-get-word (nth 1 code)))
593 (BR (setq lmc-pc (nth 1 code)))
594 (BRZ (setq lmc-pc (if (zerop lmc-acc)
597 (BRP (setq lmc-pc (if (< lmc-acc 500)
600 ((nil) (error "Invalid instruction %S" inst))
601 (t (error "%S not implemented" code))))
605 "Run the code until hitting a HLT.
606 The machine will also stop if the user presses a key."
608 (while (not (or (unless lmc-turbo (input-pending-p)) (lmc-stopped-p)))
610 (lmc--sit-for 0.05)))
612 ;;; The LMC assembly language editor.
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)
621 (easy-menu-define lmc-asm-menu lmc-asm-mode-map
622 "Menu for the LMC-Asm mode."
624 ["Assemble" lmc-asm-assemble]
625 ["Load into Simulator" lmc-asm-load]))
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)
634 (defconst lmc-asm-mnemonic-names-re (regexp-opt lmc-asm-mnemonic-names))
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))))
642 (defvar lmc-asm-imenu-generic-expression
643 '((nil "^\\(\\(?:\\sw\\|\\s_\\)+\\)" 1)))
645 (defvar lmc-asm-outline-regexp "^\\(?:\\sw\\|\\s_\\)")
647 ;; We use the ".elmc" extension since the syntax is not identical to
648 ;; the usual ".lmc" syntax.
650 (add-to-list 'auto-mode-alist '("\\.elmc\\'" . lmc-asm-mode))
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]\\)\\(\\\\\\\\\\)*\\);+ *")
670 (defun lmc-asm-labels (string)
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))
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)))
688 (defun lmc-asm-completion ()
690 (let ((ppss (syntax-ppss)))
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))
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_")
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))))))))
707 (defun lmc-asm-indentation ()
709 (back-to-indentation)
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)))))
719 (defun lmc-asm-indent-line (&optional arg)
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.
726 (if (assq (read (current-buffer)) lmc-mnemonic-0-table)
728 (let ((eol (line-end-position)))
730 (read (current-buffer))
731 (when (<= (point) eol)
733 (let ((indent (lmc-asm-indentation)))
735 ((null indent) (lisp-indent-line arg))
737 (let ((left-margin indent)) (indent-to-left-margin))
739 ;; Indent code (if any) after a label.
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 " "))))))))))
754 (defun lmc-asm-read ()
756 (initialpos (point)))
757 (goto-char (point-min))
758 (while (progn (forward-comment (point-max))
760 (let ((start (point)))
762 (push (cons (point) (read (current-buffer))) prog)
763 (end-of-file (goto-char start) (signal 'end-of-file nil)))))
764 (goto-char initialpos)
767 (defun lmc-asm-load ()
768 "Load current buffer into the LMC simulator."
770 (let ((initialpos (point))
771 (window (if (eq (current-buffer) (window-buffer)) (selected-window))))
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)))))
778 (defun lmc-asm-assemble ()
779 "Assemble current buffer to check syntax."
781 (let ((initialpos (point)))
782 (lmc--assemble (lmc-asm-read))
783 (goto-char initialpos)
784 (message "No errors found")))
786 (defun lmc-load-file (file)
787 "Load FILE into the LMC simulator."
789 (list (read-file-name "Load LMC file: " nil nil t nil
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)))
796 (with-current-buffer buf
799 (error (error "Error at line %d: %s" (line-number-at-pos)
800 (error-message-string err)))))
801 (unless exists (kill-buffer buf)))))