;;; lmc.el --- Little Man Computer in Elisp
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2013 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Version: 1.2
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; The simulator uses a plain editable buffer, so you can edit the machine
;; words just like any other text, and every word can be given a name (label)
-;; which can also be edited in the normal way.
-
-;; The assembly uses a slightly different (Lispish) syntax where each
-;; instruction needs to be wrapped in parentheses. Other than hat it's the
-;; same assembly as documented elsewhere (accepts a few mnemonic variants, such
-;; as IN/INP, STA/STO).
-;; The lmc-asm-mode supports all the usual editing features such as label
+;; which can also be edited in the normal way. Additionally to the labels it
+;; shows the disassembled meaning of instruction words. Of course, it can't
+;; always know which words are meant to be code rather than data, so it relies
+;; on information from the assembler to do that, and otherwise just marks every
+;; word it executes as being "code".
+
+;; The assembly uses a slightly different (Lispish) syntax where comments start
+;; with ";", and each instruction needs to be wrapped in parentheses.
+;; Other than that it's the same assembly as documented elsewhere
+;; (accepts a few mnemonic variants, such as IN/INP, STA/STO, BR/BRA).
+;; Another difference is that the DAT mnemonic accepts any number of words
+;; rather than just one.
+;;
+;; So the assembly (stored in files with extension ".elmc") looks like:
+;;
+;; label1
+;; (BR label2) ;Useless extra jump.
+;; label2
+;; (LDA data1) ;Cleverest part of the algorithm.
+;; (ADD data2)
+;; (STO data1)
+;; (BR label1)
+;;
+;; data1 (DAT 0)
+;; data2 (DAT 050 060 070)
+;;
+;; And actually, since the assembler re-uses the Emacs Lisp reader to parse the
+;; code, you can use binary, octal, and hexadecimal constants as well, using
+;; the notations #b101010, #o277, and #x5F respectively.
+;;
+;; The lmc-asm-mode supports the usual editing features such as label
;; completion, mnemonic completion, jumping to a label, automatic indentation,
-;; and even code folding.
-
-;; FIXME:
-;; - can't set lmc-pc and lmc-acc.
+;; and code folding.
;;; Code:
(eval-when-compile (require 'cl))
(require 'hexl)
+(defgroup lmc ()
+ "Customization group for the Little Man Computer simulator."
+ :group 'languages)
+
;;; The LMC-Simulator
(defvar lmc--pc 0 "Program counter for LMC.")
(defvar lmc-acc 0 "Accumulator for LMC.")
(make-variable-buffer-local 'lmc--acc)
+(defvar lmc-turbo nil
+ "When non-nil, evaluate the code without extra delays.
+When nil, evaluation flashes the cursor at to help you see what's going on,
+which slows it down significantly.
+Also, when nil, evaluation is interrupted when the user hits a key.")
+
+;; Emacs-22 backward compatibility.
+(defmacro lmc--with-silent-modifications (&rest body)
+ (declare (debug t) (indent 0))
+ (if (fboundp 'with-silent-modifications)
+ `(with-silent-modifications ,@body)
+ (let ((modified (make-symbol "modified")))
+ `(let* ((,modified (buffer-modified-p))
+ (buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t)
+ deactivate-mark
+ ;; Avoid setting and removing file locks and checking
+ ;; buffer's uptodate-ness w.r.t the underlying file.
+ buffer-file-name
+ buffer-file-truename)
+ (unwind-protect
+ (progn
+ ,@body)
+ (unless ,modified
+ (restore-buffer-modified-p nil)))))))
+
;; (defun lmc-check (cmds)
;; (dolist (cmd cmds)
;; (pcase cmd
;; First pass, resolve labels to their positions.
(dolist (cmd cmds)
(setq cmd (cdr cmd)) ;Ignore position info at this stage.
- (if (or (consp cmd)
- (assq cmd lmc-mnemonic-0-table))
- (setq pos (+ pos (if (eq (car cmd) 'DAT)
- (1- (length cmd)) 1)))
+ (cond
+ ((or (consp cmd)
+ (assq cmd lmc-mnemonic-0-table))
+ (setq pos (+ pos (if (eq (car cmd) 'DAT)
+ (1- (length cmd)) 1))))
+ ((numberp cmd)
+ (cond
+ ((not (and (natnump cmd) (< cmd 100)))
+ (error "%S is not a valid address" cmd))
+ ((< cmd pos)
+ (error "Address %S already used" cmd))
+ ((rassq pos labels)
+ (error "Label %S needs to come after address %S"
+ (car (rassq pos labels)) cmd))
+ (t (setq pos cmd))))
+ ((and cmd (symbolp cmd))
;; (assert (symbolp cmd))
- (push (cons cmd pos) labels)))
+ (if (assq cmd labels)
+ (error "Duplicate label %S" cmd)
+ (push (cons cmd pos) labels)))))
;; Second pass, do the actual assembly.
(let* ((words ())
(ll nil)
(+ (* 100 (cdr (assq (car cmd) lmc-mnemonic-1-table)))
(lmc--resolve (nth 1 cmd) labels 100))
'code))
+ ((numberp cmd)
+ (dotimes (_ (- cmd (length words)))
+ (funcall newword 0)))
((and cmd (symbolp cmd))
(assert (eq (cdr (assq cmd labels)) (length words)))
(setq ll cmd))
(let ((code (car (rassq (/ word 100) lmc-mnemonic-1-table))))
(cond
(code (list code (mod word 100)))
- ((rassq word lmc-mnemonic-1-table)
- (list (car (rassq word lmc-mnemonic-1-table)))))))
+ ((rassq word lmc-mnemonic-0-table)
+ (list (car (rassq word lmc-mnemonic-0-table)))))))
(defun lmc-addr->point (addr)
(goto-char (point-min))
(defvar lmc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-s" 'lmc-step)
+ (define-key map "\C-c\C-r" 'lmc-run)
(define-key map "\C-c\C-l" 'lmc-load-file)
+ (define-key map "\C-c\C-a" 'lmc-set-acc)
+ (define-key map "\C-c\C-p" 'lmc-set-pc)
map))
(easy-menu-define lmc-menu lmc-mode-map "Menu for LMC-Sim."
'("LMC-Sim"
["Step" lmc-step (not (lmc-stopped-p))]
- ["Load file" lmc-load-file]))
+ ["Run" lmc-run (not (lmc-stopped-p))]
+ ["Load file" lmc-load-file]
+ "--"
+ ["Set Program Counter" lmc-set-pc]
+ ["Set Accumulator" lmc-set-acc]))
+
+(defvar lmc-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item "gud/next" 'lmc-step 'step map
+ :label "Step" ;; :vert-only t
+ :enable '(not (lmc-stopped-p))
+ )
+ (tool-bar-local-item "gud/run" 'lmc-run 'run map
+ :label "Run" ;; :vert-only t
+ :enable '(not (lmc-stopped-p))
+ )
+ map))
+
+(defun lmc-tool-bar-to-string (&optional map)
+ (let ((res ""))
+ (map-keymap
+ (lambda (k v)
+ (when (eq (car v) 'menu-item)
+ (let* ((label (nth 1 v))
+ (cmd (nth 2 v))
+ (plist (nthcdr (if (consp (nth 3 v)) 4 3) v))
+ (help-echo (plist-get plist :help))
+ (image (plist-get plist :image))
+ (enable-exp (if (plist-member plist :enable)
+ (plist-get plist :enable)
+ t))
+ (enable (eval enable-exp))
+ (map (let ((map (make-sparse-keymap)))
+ (define-key map [header-line mouse-1] cmd)
+ (define-key map [header-line mouse-2] cmd)
+ map))
+ (button
+ (propertize " " 'help-echo (or help-echo label)
+ 'keymap map
+ 'face 'header-line
+ 'mouse-face (if enable 'mode-line-highlight)
+ 'rear-nonsticky '(display keymap help-echo)
+ 'display (if (and (eq 'image (car image))
+ (not enable))
+ `(image :conversion disabled
+ ,@(cdr image))
+ image))))
+ (setq res (concat res (propertize " " 'display '(space :width 0.5)
+ 'face 'header-line
+ )
+ button)))))
+ (or (let ((tool-bar-map map)) (tool-bar-make-keymap))
+ (key-binding [tool-bar])))
+ res))
(define-derived-mode lmc-mode fundamental-mode "LMC-Sim"
"The simulator of the Little Man Computer."
'(lmc-font-lock-keywords t))
(set (make-local-variable 'font-lock-extra-managed-props)
'(display help-echo))
+ ;; (set (make-local-variable 'tool-bar-map) lmc-tool-bar-map)
(add-hook 'after-change-functions #'lmc-after-change nil t)
(set (make-local-variable 'lmc-label-table) (make-vector 100 nil))
(set (make-local-variable 'overlay-arrow-position) (point-min-marker))
(lmc-update-pc)
;; (overwrite-mode 1)
(set (make-local-variable 'header-line-format)
- '("LMC-Sim PC=" (:eval (format "%02d" lmc-pc))
- " ACC=" (:eval (format "%03d" lmc-acc))
- " Recent output: "
+ `(""
+ (:eval (lmc-tool-bar-to-string lmc-tool-bar-map))
+ " " ,(propertize "LMC-Sim" 'face '(bold italic)) " "
+ ,(propertize "PC=" 'face 'font-lock-function-name-face)
+ (:eval (format ,(propertize "%02d"
+ 'mouse-face 'mode-line-highlight
+ 'help-echo
+ "mouse-2: set the Program Counter"
+ 'follow-link t
+ ;; I'm having problems with mouse-2 to
+ ;; mouse-1 remapping in the mode-line and
+ ;; header-line, so I over-do it a bit.
+ 'keymap
+ '(keymap
+ (header-line keymap
+ (down-mouse-1 . ignore)
+ (mouse-2 . lmc-set-pc)
+ (mouse-1 . lmc-set-pc))))
+ lmc-pc))
+ " " ,(propertize "ACC=" 'face 'font-lock-function-name-face)
+ (:eval (format ,(propertize "%03d"
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "mouse-2: set the Accumulator"
+ 'follow-link t
+ 'keymap
+ ;; I'm having problems with mouse-2 to
+ ;; mouse-1 remapping in the mode-line and
+ ;; header-line, so I over-do it a bit.
+ '(keymap
+ (header-line keymap
+ (down-mouse-1 . ignore)
+ (mouse-2 . lmc-set-acc)
+ (mouse-1 . lmc-set-acc))))
+ lmc-acc))
+ " " ,(propertize "Recent output="
+ 'face 'font-lock-function-name-face)
(:eval (if lmc-output (format "%s" lmc-output) "()"))))
)
+(defun lmc-set-pc (pc)
+ "Set the Program Counter."
+ (interactive (list (read-number "New PC: " lmc-pc)))
+ (setq lmc-pc pc)
+ (lmc-update-pc))
+
+(defun lmc-set-acc (acc)
+ "Set the Accumulator."
+ (interactive (list (read-number "New Accumulator: " lmc-acc)))
+ (setq lmc-acc (mod acc 1000)))
+
(defun lmc-load (words)
(pop-to-buffer "*LMC-Sim*")
(lmc-mode)
(setq addr (1+ addr))))
(lmc-update-pc))
-(defvar lmc-store-flash t)
+(defcustom lmc-store-flash t
+ "If non-nil, memory words blink when modified."
+ :type 'boolean)
+
+(defun lmc--sit-for (secs)
+ (unless lmc-turbo (sit-for secs)))
(defun lmc-store-word (addr word)
(save-excursion
(lmc-addr->point addr)
(if (not (re-search-forward "\t.*\t\\(.*\\)$" (line-end-position) t))
(error "Missing memory cell %S" addr)
- (when lmc-store-flash
- (with-silent-modifications
- (put-text-property (match-beginning 1) (point)
- 'face 'region))
- (sit-for 0.5))
- (replace-match (format " %03d" word) t t nil 1)
- (when lmc-store-flash
- (sit-for 0.1)
- (with-silent-modifications
- (put-text-property (match-beginning 1) (point)
- 'face 'region))
- (sit-for 0.1)
- (with-silent-modifications
- (put-text-property (match-beginning 1) (point)
- 'face nil))
- (sit-for 0.1)))))
+ (let ((mb1 (match-beginning 1)))
+ (when lmc-store-flash
+ (lmc--with-silent-modifications
+ (put-text-property mb1 (point) 'face 'region))
+ (lmc--sit-for 0.2))
+ (let ((me1 (point)))
+ (insert (format " %03d" word)) (delete-region mb1 me1))
+ (when lmc-store-flash
+ (lmc--sit-for 0.1)
+ (lmc--with-silent-modifications
+ (put-text-property mb1 (point) 'face 'region))
+ (lmc--sit-for 0.1)
+ (lmc--with-silent-modifications
+ (put-text-property mb1 (point) 'face nil))
+ (lmc--sit-for 0.1))))))
(defun lmc-step ()
"Execute one LMC instruction."
(case (car code)
(HLT (if (lmc-stopped-p)
(error "Already halted")
- (setq lmc--stopped (lmc--state)) (message "Done.")))
+ (setq lmc--stopped (lmc--state))
+ (force-mode-line-update)
+ (message "Done.")))
(IN (setq lmc-acc (mod (read-number "Enter a number") 1000))
(incf lmc-pc))
(OUT (message "Output: %03d" lmc-acc)
(t (error "%S not implemented" code))))
(lmc-update-pc))
+(defun lmc-run ()
+ "Run the code until hitting a HLT.
+The machine will also stop if the user presses a key."
+ (interactive)
+ (while (not (or (unless lmc-turbo (input-pending-p)) (lmc-stopped-p)))
+ (lmc-step)
+ (lmc--sit-for 0.05)))
+
;;; The LMC assembly language editor.
(defvar lmc-asm-mode-map
(t (forward-comment (point-max)) (lmc-asm-indentation)))))
(defun lmc-asm-indent-line (&optional arg)
+ (save-excursion
+ (back-to-indentation)
+ (when (and (zerop (nth 0 (syntax-ppss)))
+ (looking-at (concat lmc-asm-mnemonic-names-re "\\_>")))
+ ;; Apparently the user forgot to parenthesize the instruction.
+ (insert "(")
+ (if (assq (read (current-buffer)) lmc-mnemonic-0-table)
+ (insert ")")
+ (let ((eol (line-end-position)))
+ (ignore-errors
+ (read (current-buffer))
+ (when (<= (point) eol)
+ (insert ")")))))))
(let ((indent (lmc-asm-indentation)))
(cond
((null indent) (lisp-indent-line arg))
(nreverse prog)))
(defun lmc-asm-load ()
- "Load current buffer into the LMC simluator."
+ "Load current buffer into the LMC simulator."
(interactive)
(let ((initialpos (point))
(window (if (eq (current-buffer) (window-buffer)) (selected-window))))