;MMC-CHIP-8 - My Meta-Machine Code targeted at CHIP-8.
;Copyright (C) 2019,2020,2021 Prince Trippy programmer@verisimilitudes.net.
;This program is free software: you can redistribute it and/or modify it under the terms of the
;GNU Affero General Public License version 3 as published by the Free Software Foundation.
;This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without
;even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;See the GNU Affero General Public License for more details.
;You should have received a copy of the GNU Affero General Public License along with this program.
;If not, see .
(cl:defpackage #:mmc-chip-8
(:documentation "The MMC is an advanced machine code development tool, this targeted at CHIP-8.")
(:use #:common-lisp #:shut-it-down #:acute-terminal-control)
(:import-from #:cl-ecma-48 #:carriage-return #:line-feed #:erase-in-line #:erase-in-page
#:set-mode #:reset-mode)
(:shadow #:disassemble #:delete)
(:export #:prime))
(cl:in-package #:mmc-chip-8)
(assert (<= 4096 array-dimension-limit))
(assert (<= 4096 array-total-size-limit))
(deftype octet () '(unsigned-byte 8))
(deftype mmc-type () '(member :instruction :octet :hextet :subordinate))
(deftype association () '(member :none :lower-nibble :upper-nibble :octet :address :hextet))
(defstruct (name :copier (:constructor make-name (value id &optional label-p)))
"A name is an abstract, sixteen-bit value with a unique name.
A label is displayed with the address that its value corresponds to."
(value 0 :type (unsigned-byte 16)) (id "" :type string) (label-p nil :type boolean))
(defstruct (instruction :conc-name
(:constructor make-instruction (&key C XXX X YY Y Z N1 A1 N2 A2)))
""
(C 0 :type (unsigned-byte 4)) (X 0 :type (unsigned-byte 4)) (Y 0 :type (unsigned-byte 4))
(Z 0 :type (unsigned-byte 4)) (YY 0 :type octet) (XXX 0 :type (unsigned-byte 12))
(N1 nil :type (or null name)) (A1 :none :type association) ;I've been bitten often by errors here.
(N2 nil :type (or null name)) (A2 :none :type association))
(defstruct (metadata (:constructor make-metadata (&key type association names)))
"The metadata of a CHIP-8 program is represented as parallel arrays, for size efficiency.
This is two arrays of keywords and an array of name codes."
(type (make-array 4096 :element-type 'mmc-type
:initial-contents (loop :for count :from 0 :to 4095
:collect (if (evenp count) :instruction :subordinate)))
:type (vector mmc-type 4096))
(association (make-array 4096 :element-type 'association :initial-element :none)
:type (vector association 4096))
(names (make-array 4096 :element-type '(unsigned-byte 11) :initial-element 0)
:type (vector (unsigned-byte 11) 4096)))
;These definition macroes are clearly not for external use, and so I've made little effort to clean.
(defmacro defzero (symbol display &aux (identity (parse-integer (symbol-name symbol)
:end 1 :radix 16))
(make-symbol (intern (concatenate 'string (symbol-name 'make-)
(symbol-name symbol))))
(print (intern (concatenate 'string (symbol-name 'display-)
(symbol-name symbol)))))
(declare (type symbol symbol) (type string display))
""
`(progn (defun ,make-symbol (instruction namespace subst)
,(format nil "Create a ~S instruction: (~S DEFAULTS AVAILABLE-NAMES)"symbol make-symbol)
;As a convenience, writing that same instruction being overwritten changes the defaults.
(and subst (= ,identity (C subst)) (setq instruction subst))
(multiple-value-bind (integer name)
(ask-address (XXX instruction) (if (eq :address (A1 instruction)) (N1 instruction))
namespace)
(make-instruction :C ,identity :XXX integer
:N1 name :A1 (if name :address :none) :N2 nil :A2 :none)))
(defun ,print (instruction)
,(format nil "Display a ~S instruction." symbol)
(or (= ,identity (C instruction))
(error "~S called with improper instruction." ',print))
,(let ((search (search "NNNN" display)))
`(format t ,(if search (concatenate 'string (subseq display 0 search)
"~:[~*~4,'0D~;~/MMC-CHIP-8::DISPLAY-NAME/~]"
(subseq display (+ 4 search)))
display)
(eq :address (A1 instruction))
(name-id (N1 instruction))
(XXX instruction))))))
(defmacro defconstzero (identity display
&aux (symbol (intern (format nil "~A~4,'0X" (symbol-name 'make-) identity)))
(print (intern (format nil "~A~4,'0X" (symbol-name 'display-) identity))))
(declare (type unsigned-byte identity) (type string display))
""
`(progn (defun ,symbol (instruction namespace subst)
(declare (ignore instruction namespace subst))
,(format nil "Create a ~4,'0X instruction; arguments are ignored." identity)
(make-instruction :C 0 :XXX ,identity :N1 nil :A1 :none :N2 nil :A2 :none))
(defun ,print (instruction)
,(format nil "Display a ~4,'0X instruction." identity)
(or (= ,identity (XXX instruction))
(error "~S called with improper instruction." ',print))
(write-string ,display))))
(defmacro defone (symbol display &aux (identity (parse-integer (symbol-name symbol)
:end 1 :radix 16))
(subidentity (parse-integer (symbol-name symbol)
:start 2 :radix 16 :junk-allowed t))
(make-symbol (intern (concatenate 'string (symbol-name 'make-)
(symbol-name symbol))))
(print (intern (concatenate 'string (symbol-name 'display-)
(symbol-name symbol)))))
(declare (type symbol symbol) (type string display))
""
`(progn (defun ,make-symbol (instruction namespace subst)
,(format nil "Create a ~S instruction: (~S DEFAULTS AVAILABLE-NAMES)"symbol make-symbol)
;As a convenience, writing that same instruction being overwritten changes the defaults.
(and subst (= ,identity (C subst))
,@(if subidentity `((= ,subidentity (YY subst)))) (setq instruction subst))
(multiple-value-bind (integer name)
(ask-register (X instruction) (if (eq :lower-nibble (A1 instruction))
(N1 instruction))
namespace)
,(if subidentity
`(make-instruction :C ,identity :X integer :YY ,subidentity
:N1 name :A1 (if name :lower-nibble :none) :N2 nil :A2 :none)
`(multiple-value-bind (third fourth)
(progn (prepare-for-question)
(ask-byte (YY instruction) (if (eq :octet (A2 instruction))
(N2 instruction))
namespace))
(make-instruction :C ,identity :X integer :YY third
:N1 name :A1 (if name :lower-nibble :none)
:N2 fourth :A2 (if fourth :octet :none))))))
(defun ,print (instruction)
,(format nil "Display a ~S instruction." symbol)
(or (and (= ,identity (C instruction))
,@(if subidentity `((= ,subidentity (YY instruction)))))
(error "~S called with improper instruction." ',print))
,(let* ((search (search "NNN" display)) (position (search "VX" display))
(nth (search "VX" display :start2 (+ 2 position))) (char (search "OO" display)))
`(format t ,(if (or search position nth char)
(concatenate 'string (subseq display 0 position)
"V~X"
(subseq display (+ 2 position) (or nth search char))
(if nth "~:*V~X")
(if nth (subseq display (+ 2 nth) (or search char)))
(if search "~:[~*~3,'0D~;~/MMC-CHIP-8::DISPLAY-NAME/~]")
(if search (subseq display (+ 3 search)))
(if char "~2,'0D")
(if char (subseq display (+ 2 char))))
display)
(X instruction)
,@(if search '((eq :octet (A2 instruction))
(name-id (N2 instruction))
(YY instruction)))
,@(if char '((1+ (X instruction)))))))))
(defmacro deftwo (symbol display &aux (identity (parse-integer (symbol-name symbol)
:end 1 :radix 16))
(subidentity (parse-integer (symbol-name symbol)
:start 3 :radix 16))
(make-symbol (intern (concatenate 'string (symbol-name 'make-)
(symbol-name symbol))))
(print (intern (concatenate 'string (symbol-name 'display-)
(symbol-name symbol)))))
(declare (type symbol symbol) (type string display))
""
`(progn (defun ,make-symbol (instruction namespace subst)
,(format nil "Create a ~S instruction: (~S DEFAULTS AVAILABLE-NAMES)"symbol make-symbol)
;As a convenience, writing that same instruction being overwritten changes the defaults.
(and subst (= ,identity (C subst)) (= ,subidentity (Z subst)) (setq instruction subst))
(multiple-value-bind (first second)
(ask-register (X instruction) (if (eq :lower-nibble (A1 instruction))
(N1 instruction))
namespace "First register ")
(prepare-for-question)
(multiple-value-bind (third fourth)
(ask-register (Y instruction) (if (eq :upper-nibble (A2 instruction))
(N2 instruction))
namespace "Second register ")
(make-instruction :C ,identity :X first :Y third :Z ,subidentity
:N1 second :A1 (if second :lower-nibble :none)
:N2 fourth :A2 (if fourth :upper-nibble :none)))))
(defun ,print (instruction)
,(format nil "Display a ~S instruction." symbol)
(or (and (= ,identity (C instruction)) (= ,subidentity (Z instruction)))
(error "~S called with improper instruction." ',print))
,(let* ((search (search "VY" display)) (position (search "VX" display))
(nth (search "VX" display :start2 (+ 2 position))))
`(format t ,(if (or search position nth)
(concatenate 'string (subseq display 0 position)
"V~X"
(subseq display (+ 2 position) (or nth search))
(if nth "~@*V~X")
(if nth (subseq display (+ 2 nth) (or search)))
(if search "V~X")
(if search (subseq display (+ 2 search))))
display)
(X instruction) (Y instruction)))))) ;Names are never printed for such here.
(defmacro defspecial (symbol &body rest)
""
`(progn (setf (symbol-plist ',symbol) '(:special t))
(defun ,symbol (address program metadata names)
(declare (ignorable address program metadata names))
,@rest)))
(defparameter character-set
(concatenate 'string "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz "
#+unicode "█↑→↓←:;,.?!−÷+×=∞‘’<>()[]"
#-unicode "#^/_\\:;,.?!-%+*=$`'<>()[]")
"This is the character set of the MMC targeted at CHIP-8; it's eighty-eight characters.")
(defvar rows (load-time-value (or (first (dimensions))
(error "The program can't collect the terminal dimensions.")))
"This is the count of rows of the terminal device being displayed to.")
(defvar current-row 1 "This is the active row of the program.")
(defconstant row-home 54 "This is the standing position of every row.")
(defparameter current-address #x200 "This is the current address under attention.")
(defparameter top-address current-address
"This is the first address shown and simplifies redisplay.")
;The properties available for usage include: :bold, :italics, :underlined, :blinking, and :negative.
(defparameter name-hextet-display-property :underlined
"This is what ATC:PROPERTIES will use to denote name usage, when displaying hextets in SHOW-ROW.")
(defparameter name-display-property name-hextet-display-property
"This is what ATC:PROPERTIES will use to denote name usage, when displaying names from SHOW-ROW.")
(define-condition refuse-to-answer () ())
(define-condition no-show-row () ())
(defun display-name (*standard-output* name &rest ignorable)
""
(declare (ignore ignorable))
(unwind-protect (progn (setf (properties) name-display-property) (princ name))
(setf (properties) :default)))
(defun use-color (foreground)
"Conditionally change the foreground color. This exists for regarding the choice of using color."
#-avoid-color (setf (foreground) foreground))
(defun backspace (&optional (count 1))
"Write backspace, space, and backspace, count times."
(dotimes (ignore count) (declare (ignorable ignore))
(ecma-48:backspace) (write-char #\space) (ecma-48:backspace)))
(defun resolve-name-code (name namespace)
"Resolve a name's position in the namespace, returning zero if no match is found."
(or (position name namespace :test 'equalp) 0))
(defun resolve-name-id (name namespace)
"Resolve a name in the namespace by its name alone, returning NIL if no match is found."
(find name namespace :test 'string= :key 'name-id))
(defun resolve-label-value (address namespace)
"Resolve a name which is a label by its value, returning NIL if no match is found."
(find address namespace :test (lambda (first second)
(and (name-label-p second) (= first (name-value second))))))
;(defun change-name-id (name set namespace &aux (find (resolve-name-id name namespace)))
; "Change the identifier of a resolved name to SET, if it exists, and otherwise ignore the request."
; (if find (setf (name-id find) set)))
(defun read-string (&aux character (string (make-array 15 :element-type 'character :adjustable t
:fill-pointer 0)))
"Read in a single line of fifteen characters or less."
(finish-output)
(use-color :magenta)
(unwind-protect (loop (setq character (read-event))
(cond ((characterp character)
#+unicode
(setq character
(or (cdr (assoc character
(pairlis (coerce "#^/_\\-%*$`'" 'list)
(coerce "█↑→↓←−÷×∞‘’" 'list))
:test 'char=))
character))
(case character
(#.(code-char 27) (signal 'refuse-to-answer))
((#\newline #.(code-char 10) #.(code-char 13)) (return string))
((#.(code-char 8) #.(code-char 127))
(cond ((not (zerop (length string)))
(vector-pop string)
(backspace))))
(t (and (find character character-set :test 'char=)
(vector-push character string)
(write-char character))))
(finish-output))))
(use-color :default)))
(defun read-integer
(max default default-name namespace &optional name
&aux character digit-char-p (count 0) (*print-base* 10) (erase-in-line (not name))
(string (make-array 16 :element-type 'character :adjustable t :fill-pointer 0))
(namestring (make-array 15 :element-type 'character :adjustable t :fill-pointer 0)))
"Read in an integer below max, with defaults in the case of a blank line.
To handle the case of no input and escape, the condition REFUSE-TO-ANSWER will be SIGNALed.
Start in name-reading mode if the optional argument is true."
(finish-output)
(and default-name ;(not (equal default-name (aref namespace 0)))
(/= default (name-value default-name)) ;This should be an unnecessary check, as a precaution.
(error "READ-INTEGER called with mismatched defaults: ~S ~S" default (name-id default-name)))
(cond ((not name)
(use-color '(:rgb 128 128 128)) ;The default answer is shown with this nice choice of grey.
(princ default)
(cond (default-name (write-char #\!) (ecma-48:backspace))) ;The LENGTH was actually easier.
(dotimes (count (if (zerop default) 1 (ceiling (log (1+ default) 10))))
(declare (ignorable count)) (ecma-48:backspace))))
(use-color :magenta)
(unwind-protect
(loop (finish-output)
(setq character (read-event))
(cond (erase-in-line (erase-in-line) (setq erase-in-line nil)))
(if (characterp character)
(if name
(case character
(#.(code-char 27) (signal 'refuse-to-answer))
(#.(code-char 9)
(setq name nil) (backspace (length namestring)) (write-string string))
((#\newline #.(code-char 10) #.(code-char 13))
(if (zerop (length namestring)) (return (values default default-name)))
(let ((name (resolve-name-id namestring namespace)))
(and name (>= max (name-value name))
(return (values (name-value name) name)))))
((#.(code-char 8) #.(code-char 127))
(cond ((not (zerop (length namestring)))
(vector-pop namestring)
(backspace))))
(t #+unicode
(setq character (or (cdr (assoc character
(pairlis (coerce "#^/_\\-%*$`'" 'list)
(coerce "█↑→↓←−÷×∞‘’" 'list))
:test 'char=))
character))
(if (vector-push character namestring)
(write-char character))))
(if (setq character ;The following establishes the bindings of rows and digits.
(or
(cdr (assoc character
(pairlis #+qwerty (coerce "asdfghjkl;qwertyuiop'" 'list)
#-qwerty (coerce "aoeuidhtns',.pyfgcrl-" 'list)
(coerce "1234567890ABCDEABCDEF" 'list))
:test 'char=))
character)
digit-char-p (digit-char-p character *print-base*))
(cond ((and (>= max (setq digit-char-p (+ digit-char-p
(* count *print-base*))))
(vector-push character string))
(setq count digit-char-p)
(write-char (char-upcase character))))
(case character
(#.(code-char 27) (signal 'refuse-to-answer))
(#.(code-char 9)
(setq name t) (backspace (length string)) (write-string namestring))
((#\newline #.(code-char 10) #.(code-char 13)
. #+qwerty #.(coerce "zxcvbnm,./" 'list)
#-qwerty #.(coerce ";qjkxbmwvz" 'list))
(return (if (zerop (length string))
(values default default-name) count)))
((#.(code-char 8) #.(code-char 127) #\space)
(cond ((not (zerop (length string)))
(setq count (floor count *print-base*))
(vector-pop string)
(backspace))))
(#1=#.(map 'list 'code-char #+qwerty '(1 19 4 6) #-qwerty '(1 15 5 21))
(setq *print-base* (cdr (assoc character
'#.(pairlis '#1# '(2 8 10 16)))))
(cond ((not (zerop (length string)))
(backspace (length string))
(setf (fill-pointer string) 0)
(with-output-to-string (stream string) (princ count stream))
(write-string string)))))))))
(use-color :default)))
(defun read-name-id (namespace &aux (name (nth-value 1 (read-integer 65535 0 (aref namespace 0)
namespace t))))
"Read in a string which is a valid name identifier, and return the name directly."
(or name (aref namespace 0)))
(defun prepare-for-question ()
""
(setf (cursor) (cons current-row (1+ row-home)))
(erase-in-line))
(defun ask-address (default name namespace)
""
(write-string "Address ")
(read-integer 4095 default name namespace))
(defun ask-register (default name namespace &optional (string "Register "))
""
(write-string string)
(read-integer 15 default name namespace))
(defun ask-byte (default name namespace)
""
(write-string "Byte ")
(read-integer 255 default name namespace))
(defun ask-height (default name namespace)
""
(write-string "Height ")
(read-integer 16 default name namespace))
(defun ask-shift (default name namespace)
""
(ask-register default name namespace "Shift amount "))
(defun ask-yes-or-no (string namespace)
""
(prepare-for-question)
(write-string string)
(not (zerop (read-integer 1 0 nil namespace t))))
(defun require-acknowledgement (string)
""
(prepare-for-question)
(write-string string)
(finish-output)
(loop (case (read-event)
(#.(code-char 27) (signal 'refuse-to-answer))
((#\newline #.(code-char 10) #.(code-char 13)
. #+qwerty #.(coerce "zxcvbnm,./" 'list)
#-qwerty #.(coerce ";qjkxbmwvz" 'list))
(return)))))
;These definitions comprise the personality of the tool.
(defzero 0XXX "Jump to COSMAC VIP NNNN")
(defzero 1XXX "Jump to NNNN")
(defzero 2XXX "Call NNNN")
(defzero AXXX #+unicode "I ← NNNN" #-unicode "I <- NNNN")
(defzero BXXX "Jump to V0 + NNNN")
(defconstzero #x00E0 "Clear the screen")
(defconstzero #x00EE "Return")
(defconstzero #x00FB #+unicode "Scroll → by 04" #-unicode "Scroll right by 04")
(defconstzero #x00FC #+unicode "Scroll ← by 04" #-unicode "Scroll left by 04")
(defconstzero #x00FD "Exit program")
(defconstzero #x00FE "Disable extended mode")
(defconstzero #x00FF "Enable extended mode")
(defone 3XYY "Skip next if VX = NNN")
(defone 4XYY "Skip next if VX <> NNN")
(defone 6XYY #+unicode "VX ← NNN" #-unicode "VX <- NNN")
(defone 7XYY #+unicode "VX ← VX + NNN" #-unicode "VX <- VX + NNN")
(defone CXYY #+unicode "VX ← ??? AND NNN" #-unicode "VX <- ??? AND NNN")
(defone EX9E "Skip next if VX = key")
(defone EXA1 "Skip next if VX <> key")
(defone FX07 #+unicode "VX ← delay" #-unicode "VX <- delay")
(defone FX0A #+unicode "VX ← key" #-unicode "VX <- key")
(defone FX15 #+unicode "delay ← VX" #-unicode "delay <- VX")
(defone FX18 #+unicode "sound ← VX" #-unicode "sound <- VX")
(defone FX1E #+unicode "I ← I + VX" #-unicode "I <- I + VX")
(defone FX29 #+unicode "I ← digit sprite of VX" #-unicode "I <- digit sprite of VX")
(defone FX30 #+unicode "I ← large digit sprite of VX" #-unicode "I <- large digit sprite of VX")
(defone FX33 "VX as BCD stored from I")
(defone FX55 #+unicode "Save V0→VX; I ← I + OO" #-unicode "Save V0->VX; I <- I + OO")
(defone FX65 #+unicode "Load V0→VX; I ← I + OO" #-unicode "Load V0->VX; I <- I + OO")
(defone FX75 #+unicode "Save V0→VX to environment; I ← I + OO"
#-unicode "Save V0->VX to environment; I <- I + OO")
(defone FX85 #+unicode "Load V0→VX to environment; I ← I + OO"
#-unicode "Load V0->VX to environment; I <- I + OO")
(deftwo 5XY0 "Skip next if VX = VY")
(deftwo 8XY0 #+unicode "VX ← VY" #-unicode "VX <- VY")
(deftwo 8XY1 #+unicode "VX ← VX OR VY" #-unicode "VX <- VX OR VY")
(deftwo 8XY2 #+unicode "VX ← VX AND VY" #-unicode "VX <- VX AND VY")
(deftwo 8XY3 #+unicode "VX ← VX XOR VY" #-unicode "VX <- VX XOR VY")
(deftwo 8XY4 #+unicode "VX ← VX + VY; VF ← overflow" #-unicode "VX <- VX + VY; VF <- overflow")
(deftwo 8XY5 #+unicode "VX ← VX − VY; VF ← borrow" #-unicode "VX <- VX - VY; VF <- borrow")
(deftwo 8XY6 #+unicode "VX ← VY ÷ 2; VF ← LSB" #-unicode "VX <- VY % 2; VF <- LSB")
(deftwo 8XY7 #+unicode "VX ← ~1@*V~X − VX; VF ← borrow" #-unicode "VX <- ~1@*V~X - VX; VF <- borrow")
(deftwo 8XYE #+unicode "VX ← VY × 2; VF ← MSB" #-unicode "VX <- VY x 2; VF <- MSB")
(deftwo 9XY0 "Skip next if VX <> VY")
(defun MAKE-DXYZ (instruction namespace subst)
"Create a DXYZ instruction: (MAKE-DXYZ DEFAULTS AVAILABLE-NAMES)"
(and subst (= #xD (C subst)) (setq instruction subst)) ;Writing DXYZ over a DXYZ changes defaults.
(multiple-value-bind (first second)
(ask-register (X instruction) (if (eq :lower-nibble (A1 instruction)) (N1 instruction))
namespace "First register ")
(prepare-for-question)
(multiple-value-bind (third fourth)
(ask-register (Y instruction) (if (eq :upper-nibble (A2 instruction)) (N2 instruction))
namespace "Second register ")
(prepare-for-question)
(multiple-value-bind (fifth sixth)
(ask-height (Z instruction) (if (eq :lower-nibble (A2 instruction)) (N2 instruction))
namespace)
(setq fifth (ldb (byte 4 0) fifth))
(and fourth sixth
(if (ask-yes-or-no "Discard the register name? " namespace) ;I'll improve this message.
(setq fourth nil)))
(make-instruction :C #xD :X first :Y third :Z fifth
:N1 second :A1 (if second :lower-nibble :none)
:N2 (or fourth sixth) :A2 (or (and fourth :upper-nibble)
(and sixth :lower-nibble)
:none))))))
(defun DISPLAY-DXYZ (instruction)
"Display a DXYZ instruction."
(or (= #xD (C instruction)) (error "~S called with improper instruction." 'display-DXYZ))
(format t #+unicode "Draw ~[16×16~:;08×~:*~2,'0D~] at V~1X,V~1X; VF ← XOR"
#-unicode "Draw ~[16x16~:;08x~:*~2,'0D~] at V~1X,V~1X; VF <- XOR"
(Z instruction) (X instruction) (Y instruction)))
(defun MAKE-00CX (instruction namespace subst)
"Create a 00CX instruction: (MAKE-00CX DEFAULTS AVAILABLE-NAMES)"
(and subst (zerop (C subst)) (= #xC (ldb (byte 12 4) (XXX subst))) (setq instruction subst))
(multiple-value-bind (integer name)
(ask-shift (ldb (byte 4 0) (XXX instruction))
(if (eq :lower-nibble (A2 instruction)) (N2 instruction))
namespace)
(make-instruction :C 0 :XXX (dpb integer (byte 4 0) #x0C0)
:N1 nil :A1 :none :N2 name :A2 (if name :lower-nibble :none))))
(defun DISPLAY-00CX (instruction)
"Display a 00CX instruction."
(or (= #xC (ldb (byte 4 4) (XXX instruction)))
(error "~S called with improper instruction." 'display-00CX))
(format t #+unicode "Scroll ↓ by ~:[~2,'0D~;~*~A~]" #-unicode "Scroll down by ~:[~2,'0D~;~*~A~]"
(eq :lower-nibble (A2 instruction))
(ldb (byte 4 0) (XXX instruction))
(name-id (N2 instruction))))
(defun MAKE-00DX (instruction namespace subst)
"Create a 00DX instruction: (MAKE-00DX DEFAULTS AVAILABLE-NAMES)"
(and subst (zerop (C subst)) (= #xD (ldb (byte 12 4) (XXX subst))) (setq instruction subst))
(multiple-value-bind (integer name)
(ask-shift (ldb (byte 4 0) (XXX instruction))
(if (eq :lower-nibble (A2 instruction)) (N2 instruction))
namespace)
(make-instruction :C 0 :XXX (dpb integer (byte 4 0) #x0D0)
:N1 nil :A1 :none :N2 name :A2 (if name :lower-nibble :none))))
(defun DISPLAY-00DX (instruction)
"Display a 00DX instruction."
(or (= #xD (ldb (byte 4 4) (XXX instruction)))
(error "~S called with improper instruction." 'display-00DX))
(format t #+unicode "Scroll ↑ by ~:[~2,'0D~;~*~A~]" #-unicode "Scroll up by ~:[~2,'0D~;~*~A~]"
(eq :lower-nibble (A2 instruction))
(ldb (byte 4 0) (XXX instruction))
(name-id (N2 instruction))))
(defun disassemble (hextet &aux (C (ldb (byte 4 12) hextet)))
""
(apply 'make-instruction :C C
(ecase C
((0 1 2 #xA #xB) `(:XXX ,(ldb (byte 12 0) hextet)))
((3 4 6 7 #xC #xE #xF) `(:X ,(ldb (byte 4 8) hextet) :YY ,(ldb (byte 8 0) hextet)))
((5 8 9 #xD) `(:X ,(ldb (byte 4 8) hextet) :Y ,(ldb (byte 4 4) hextet)
:Z ,(ldb (byte 4 0) hextet))))))
(defun assemble (instruction &aux (C (C instruction)))
""
(ecase C
((0 1 2 #xA #xB) (dpb C (byte 4 12) (XXX instruction)))
((3 4 6 7 #xC #xE #xF) (dpb C (byte 4 12) (dpb (X instruction) (byte 4 8) (YY instruction))))
((5 8 9 #xD) (dpb C (byte 4 12) (dpb (X instruction) (byte 4 8)
(dpb (Y instruction) (byte 4 4) (Z instruction)))))))
(defun extract-instruction (address program metadata names
&aux instruction (first (aref program address)))
""
(or (eq :instruction (aref (metadata-type metadata) address))
(return-from extract-instruction))
(setf instruction (disassemble (dpb first (byte 8 8) (aref program (1+ address))))
(N1 instruction) (aref names (aref (metadata-names metadata) address))
(A1 instruction) (aref (metadata-association metadata) address)
(N2 instruction) (aref names (aref (metadata-names metadata) (1+ address)))
(A2 instruction) (aref (metadata-association metadata) (1+ address)))
instruction)
(defun deposit-instruction (address program metadata names instruction
&aux (hextet (assemble instruction)))
""
(if (or (= address #xFFF) ;This behaviour is suitable for addressing edge cases affecting display.
(member (aref (metadata-type metadata) (1+ address)) '(:instruction :hextet) :test 'eq))
(return-from deposit-instruction))
(setf (aref program address) (ldb (byte 8 8) hextet)
(aref program (1+ address)) (ldb (byte 8 0) hextet)
(aref (metadata-type metadata) address) :instruction
(aref (metadata-type metadata) (1+ address)) :subordinate
(aref (metadata-association metadata) address) (A1 instruction)
(aref (metadata-association metadata) (1+ address)) (A2 instruction)
(aref (metadata-names metadata) address) (resolve-name-code (N1 instruction) names)
(aref (metadata-names metadata) (1+ address)) (resolve-name-code (N2 instruction) names))
hextet)
(defun display-instruction (instruction) ;This should be a small fraction of its current size, know.
"This ugly function is the general instruction display mechanism and is written so very horribly."
(case (C instruction) ;The basic design was from Meta-CHIP-8 and could easily use an integer code.
(0 (case (XXX instruction) ;I need to rewrite this to cap and otherwise reference with integers.
(#x0000) ;Further, these following display functions are less defensive than my old design.
(#x00E0 (display-00E0 instruction))
(#x00EE (display-00EE instruction))
(#x00FB (display-00FB instruction))
(#x00FC (display-00FC instruction))
(#x00FD (display-00FD instruction))
(#x00FE (display-00FE instruction))
(#x00FF (display-00FF instruction))
(t (case (ldb (byte 8 4) (XXX instruction))
(#x0C (display-00CX instruction))
(#x0D (display-00DX instruction))
(t (display-0XXX instruction))))))
(1 (display-1XXX instruction))
(2 (display-2XXX instruction))
(3 (display-3XYY instruction))
(4 (display-4XYY instruction))
(5 (if (zerop (Z instruction)) (display-5XY0 instruction)))
(6 (display-6XYY instruction))
(7 (display-7XYY instruction))
(8 (case (Z instruction)
(0 (display-8XY0 instruction))
(1 (display-8XY1 instruction))
(2 (display-8XY2 instruction))
(3 (display-8XY3 instruction))
(4 (display-8XY4 instruction))
(5 (display-8XY5 instruction))
(6 (display-8XY6 instruction))
(7 (display-8XY7 instruction))
(#xE (display-8XYE instruction))))
(9 (if (zerop (Z instruction)) (display-9XY0 instruction)))
(#xA (display-AXXX instruction))
(#xB (display-BXXX instruction))
(#xC (display-CXYY instruction))
(#xD (display-DXYZ instruction))
(#xE (case (YY instruction)
(#x9E (display-EX9E instruction))
(#xA1 (display-EXA1 instruction))))
(#xF (case (YY instruction)
(#x07 (display-FX07 instruction))
(#x0A (display-FX0A instruction))
(#x15 (display-FX15 instruction))
(#x18 (display-FX18 instruction))
(#x1E (display-FX1E instruction))
(#x29 (display-FX29 instruction))
(#x30 (display-FX30 instruction))
(#x33 (display-FX33 instruction))
(#x55 (display-FX55 instruction))
(#x65 (display-FX65 instruction))
(#x75 (display-FX75 instruction))
(#x85 (display-FX85 instruction))))))
;I still yearn for the following commands:
;Center the screen. I may abandon this.
;Move and copy program segments.
;List all names associated with a unit.
;Offer to associate valid names with a unit.
;Change and Recall as a recollection system.
;Search by instruction, name, or name usage, with holes.
;Allow insertions and deletions to change constants.
;Read-only mode.
;Associate all used addresses with a mechanically-generated name.
(defun make-filename (pathname)
"Accept a string which should denote part of a PATHNAME and make it a full PATHNAME.
If PATHNAME-NAME returns NIL, ``new'' is used.
The PATHNAME-DIRECTORY tries for the current, user home, and thereafter defaults by *FEATURES*."
(make-pathname :version :newest :name (or (pathname-name pathname) "new")
:defaults (or *default-pathname-defaults*
(user-homedir-pathname)
#+unix (make-pathname :directory '(:absolute "tmp"))
#+windows (make-pathname :device "C"
:directory
'(:absolute "%USERPROFILE%" "Documents")))))
(defvar type-association '((:instruction . 0) (:octet . 1) (:hextet . 2) (:subordinate . 3))
"This is the ALIST mapping of type keywords to bits.")
(defvar association-association '((:none . 0) (:lower-nibble . 1) (:upper-nibble . 2) (:octet . 3)
(:address . 5) (:hextet . 7))
"This is the ALIST mapping of association keywords to bits.")
(defun save (pathname start end program metadata names)
"Save the program and metadata to the file designated by pathname.
The metadata format is a six octet header, hextets for each program octet, and the names."
(if (> start end) (rotatef start end))
(handler-case
(let* ((save (make-filename pathname)))
(with-open-file (stream (make-pathname :type "chip8" :defaults save)
:direction :output :element-type 'octet
:if-exists :rename :if-does-not-exist :create)
(write-sequence program stream :start start :end (1+ end))
(with-open-file (stream (make-pathname :type "mmc" :defaults save)
:direction :output :element-type 'octet
:if-exists :rename :if-does-not-exist :create)
(flet ((write-two-bytes (integer)
(write-byte (ldb (byte 8 8) integer) stream)
(write-byte (ldb (byte 8 0) integer) stream)))
(write-two-bytes #x0001)
(write-two-bytes start)
(write-two-bytes end)
(loop :for nth :from start :to end
:do (write-two-bytes (dpb (cdr (assoc (aref (metadata-type metadata) nth)
type-association))
(byte 2 14)
(dpb (cdr (assoc (aref (metadata-association metadata)
nth)
association-association))
(byte 3 11)
(aref (metadata-names metadata) nth)))))
(loop :for name :across (make-array (1- (length names))
:displaced-to names :displaced-index-offset 1)
:for label-p := (if (name-label-p name) 1 0)
:doing (write-byte (dpb label-p (byte 1 4) (length (name-id name))) stream)
(write-two-bytes (name-value name))
(loop :for elt :across (name-id name)
:doing (write-byte (position elt character-set) stream))))
(write-byte 0 stream))))
(serious-condition ()
(require-acknowledgement "The save failed."))))
(define-condition instate-error (error) ((message :reader instate-error-message :initarg :message)))
(define-condition simple-instate-error (instate-error) ()) ;What an inconvenience this certainly is.
(defmacro ierror (continue) `(cerror ,continue 'instate-error :message ,continue))
(defun only-instate (pathname &optional ignore
&aux (metadata (make-metadata)) ;The NAMES code should be abstracted out later.
check-type return (start 512) (last 4095)
(instate (make-filename pathname))
(program (make-array 4096 :element-type 'octet :initial-element 0))
(names (make-array 2048 :element-type 'name :adjustable t :fill-pointer 1
:initial-element (make-name 0 ""))))
"Return data and metadata corresponding to the requested instate, designated by pathname.
Also returned are two booleans indicating whether the metadata and the data files existed.
That optional IGNORE parameter prevents any metadata from being considered, if it be true."
(with-open-file (stream (make-pathname :type "mmc" :defaults instate)
:direction :input :element-type 'octet :if-does-not-exist nil)
(setq ignore (not ignore) ;I can't set STREAM to NIL, conditionally, as it must be later closed.
return (and stream ignore))
(cond (return (or (and (zerop #0=(read-byte stream)) (= 1 #0#))
(ierror "The metadata header hextet is incorrect."))
(setq start #1=(dpb #0# (byte 8 8) #0#) last #1#)
(cond ((> start last)
(ierror "The metadata header addresses are reversed.")
(rotatef start last)))
(let ((file-length (file-length stream)))
(and file-length
(< file-length (+ 7 (* 2 (1+ (- last start)))))
(ierror "The metadata is known to be too brief.")))
(loop :for position :from start :to last :for integer := #1#
:for type := (car (rassoc (ldb (byte 2 14) integer) type-association))
:for name := (ldb (byte 11 0) integer)
:for association := (ldb (byte 3 11) integer)
:do (setf check-type type ;This lazily saves the ultimate type for a review.
(aref (metadata-type metadata) position) type
(aref (metadata-names metadata) position) name
(aref (metadata-association metadata) position)
(loop (restart-case
(return (or (car (rassoc association
association-association))
(ierror "An association code is invalid.")))
(substitute ()
:report "Correct the code using a simple heuristic."
(decf association))))))
(and (/= last 4095) ;This handles the case where otherwise :OCTET :SUBORDINATE be.
(eq :octet check-type)
(eq :subordinate #2=(aref (metadata-type metadata) (1+ last)))
(setf #2# :octet))
(loop :for first := #0# :until (zerop first)
:for name-label-p := (not (zerop (ldb (byte 1 4) first)))
:for length := (ldb (byte 4 0) first)
:for name-value := #1#
:for name-id := (make-array length :element-type 'character
:initial-contents
(loop :repeat length
:collecting (char character-set #0#)))
:unless (vector-push (make-name name-value name-id name-label-p) names)
:do (ierror "The namespace has been exhausted."))
;I believe that only aspect left to check is perhaps that name associations match.
(or (> (length names) (reduce 'max (metadata-names metadata)))
(error 'simple-instate-error :message "At least one name code is invalid."))
(or (ignore-errors
(loop :with type := (metadata-type metadata)
:for nth :from 0 :below (length type) :for elt := (aref type nth)
:always (ecase elt
(#3=(:instruction :hextet)
(eql :subordinate (aref type (1+ nth))))
(:subordinate (member (aref type (1- nth)) '#3#))
(:octet t))))
(error 'simple-instate-error :message "At least one type code is invalid."))
(if (read-byte stream nil)
(ierror "The metadata wasn't terminated properly."))))
(with-open-file (file-stream (make-pathname :type "chip8" :defaults instate)
:direction :input :element-type 'octet :if-does-not-exist nil)
(or (and ignore stream) file-stream
(error 'simple-instate-error :message "Neither data nor metadata is available."))
(cond (file-stream ;If lacking metadata, a heuristic determines that program's starting point.
(let ((file-length (file-length file-stream)))
(and ignore ;A CHIP-8 game begins at either address five hundred and twelve, or zero.
(not stream)
(and file-length (< (- 4096 512) file-length))
(setq start 0))
(and ignore (not stream)
(and file-length (> (- 4096 start) file-length))
(setq last (+ start (min last file-length))))
(cond ((< 4096 last)
(ierror "The data would be truncated.")
(setq last 4095))))
(read-sequence program file-stream :start start :end (1+ last))
(if (read-byte file-stream nil)
(ierror "The data file couldn't be read completely."))))
(values program metadata names (and ignore stream t) (if file-stream t)))))
(defspecial interactive-higher-instate ;How poor, that I merely copied the INTERACTIVE-ONLY-INSTATE.
"This is the higher interactive instating function, which exposes more options."
(declare (special current-row top-address))
(prepare-for-question)
(write-string "Filename to instate from ")
(multiple-value-bind (first second third metadata-p prog)
(handler-bind ((simple-instate-error ;Improve this later to only need that instate-error case.
(lambda (condition)
(require-acknowledgement (instate-error-message condition))
(return-from interactive-higher-instate)))
(instate-error (lambda (condition &aux (restart (find-restart 'substitute)))
(if (ask-yes-or-no (format nil "~A Continue? "
(instate-error-message condition))
names)
(if restart (invoke-restart restart) (continue))
(return-from interactive-higher-instate))))
(serious-condition (lambda (condition)
(require-acknowledgement
(format nil "The instate failed due to ~A."
(if (eq 'storage-condition (type-of condition))
"memory exhaustion" "a serious failure")))
(return-from interactive-higher-instate))))
(only-instate (read-string) (ask-yes-or-no "Ignore the metadata? " names)))
(if prog (replace program first))
(cond (metadata-p (setf (fill-pointer names) (fill-pointer third))
(replace names third))
(t (setf (fill-pointer names) 0) ;I realized, not clearing metadata still persists labels.
(create-name 0 "no" nil names) ;I should later change this code to only eliminate them.
(create-name 1 "yes" nil names)))
(setf (metadata-type metadata) (metadata-type second)
(metadata-names metadata) (metadata-names second)
(metadata-association metadata) (metadata-association second)))
(redraw-display current-row top-address program metadata names))
(defspecial interactive-only-instate
""
(declare (special current-row top-address))
(prepare-for-question)
(write-string "Filename to instate from ")
(multiple-value-bind (first second third metadata-p prog)
(handler-bind ((simple-instate-error ;Improve this later to only need that instate-error case.
(lambda (condition)
(require-acknowledgement (instate-error-message condition))
(return-from interactive-only-instate)))
(instate-error (lambda (condition &aux (restart (find-restart 'substitute)))
(if (ask-yes-or-no (format nil "~A Continue? "
(instate-error-message condition))
names)
(if restart (invoke-restart restart) (continue))
(return-from interactive-only-instate))))
(serious-condition (lambda (condition)
(require-acknowledgement
(format nil "The instate failed due to ~A."
(if (eq 'storage-condition (type-of condition))
"memory exhaustion" "a serious failure")))
(return-from interactive-only-instate))))
(only-instate (read-string) (ask-yes-or-no "Ignore the metadata? " names)))
(if prog (replace program first))
(cond (metadata-p (setf (fill-pointer names) (fill-pointer third))
(replace names third))
(t (setf (fill-pointer names) 0) ;I realized, not clearing metadata still persists labels.
(create-name 0 "no" nil names) ;I should later change this code to only eliminate them.
(create-name 1 "yes" nil names)))
(setf (metadata-type metadata) (metadata-type second)
(metadata-names metadata) (metadata-names second)
(metadata-association metadata) (metadata-association second)))
(redraw-display current-row top-address program metadata names))
(defun instate (pathname start program metadata names) ;This lambda list is subject to heavy change.
"Instate the program, ignoring any missing metadata, designated by pathname.
The format is that of SAVE; programs without metadata are instated at the address START."
(let ((instate (make-filename pathname)) (length (length names)) end)
(with-open-file (stream (make-pathname :type "mmc" :defaults instate) :direction :input
:element-type 'octet :if-does-not-exist nil)
(cond (stream (or (and (zerop #0=(read-byte stream)) (= 1 #0#))
(cerror "The metadata header hextet is incorrect." 'instate-error))
(setq start #1=(dpb #0# (byte 8 8) #0#) end (1+ #1#))
(cond ((> start end)
(cerror "The metadata header addresses are reversed." 'instate-error)
(rotatef start end)))
(if (> (file-length stream) (+ 7 (* 2 (- end start))))
(cerror "The metadata is known to be too brief." 'instate-error))
(loop :for integer := #1# :for position :from start :to end
:for type := (car (rassoc (ldb (byte 2 14) integer) type-association))
:for name := (ldb (byte 11 0) integer)
:for association := (ldb (byte 3 11) integer)
:do (setf (aref (metadata-type metadata) position) type
(aref (metadata-names metadata) position)
(if (zerop name) 0 (+ length name)) ;This is a major limitation.
(aref (metadata-association metadata) position)
(loop (restart-case
(return (or (car (rassoc association
association-association))
(cerror "An association code is invalid."
'instate-error)))
(substitute ()
:report "Correct the code using a simple heuristic."
(decf association))))))
(loop :for first := #0# ;Using CHANGE-NAME gives this atrocious time complexity.
:for name-label-p := (not (zerop (ldb (byte 1 4) first)))
:for length := (ldb (byte 4 0) first)
:for name-value := #1#
:for name-id := (make-array length :element-type 'character
:initial-contents
(loop :repeat length
:collecting (char character-set #0#)))
:for name := (change-name name-value name-id name-label-p
names metadata program)
:do (if name
()
(cerror "The namespace has been exhausted." 'instate-error)))))
(with-open-file (file-stream (make-pathname :type "chip8" :defaults instate)
:direction :input :element-type 'octet
:if-does-not-exist nil)
(or stream file-stream (cerror "Neither data nor metadata exists." 'instate-error))
(if (< 4096 (+ start (file-length file-stream)))
(cerror "The data placed here would be truncated." 'instate-error))
(read-sequence program stream :start start :end end)
(or stream))))
(handler-case ()
(serious-condition ()
(require-acknowledgement "The instate failed."))))
(defun fronttrack (address metadata &optional (count 1))
"Return the address of the following COUNT valid metadata units."
(dotimes (ignore count) (declare (ignorable ignore))
#0=(setq address (ldb (byte 12 0) (1+ address)))
(if #1=(eq :subordinate (aref (metadata-type metadata) address))
#0#)
(assert (not #1#))) ;This is strictly unnecessary.
address)
(defun backtrack (address metadata &optional (count 1))
"Return the address of the preceding COUNT valid metadata units."
(dotimes (ignore count) (declare (ignorable ignore))
#0=(setq address (ldb (byte 12 0) (1- address)))
(if #1=(eq :subordinate (aref (metadata-type metadata) address))
#0#)
(assert (not #1#))) ;This is strictly unnecessary.
address)
(defun jump (address program metadata names)
"Jump to a new memory location, redisplaying from there, adjusting as necessary."
(declare (special current-row current-address top-address))
(setq current-address (redraw-display (setq current-row 1) address program metadata names)
top-address current-address))
(defspecial less-interactive-save
"Interactively prompt for filename to store the program and bounds thereof."
(prepare-for-question)
(write-string "Filename to save to ")
(let* ((pathname (read-string))
(first (progn (prepare-for-question)
(write-string "Starting address ")
(ask-address 512 nil names)))
(last (progn (prepare-for-question)
(write-string "Ending address ")
(ask-address (min 4095
(max (1+ first)
(or (position-if-not 'zerop program :from-end t) 0)
(or (position-if-not (lambda (association)
(eq association :none))
(metadata-association metadata)
:from-end t)
0)))
nil names))))
(save pathname first last program metadata names)))
(defspecial interactive-jump
"Interactively jump to a new memory location, redisplaying from there, adjusting if necessary."
(declare (special current-row current-address))
(prepare-for-question)
(jump (ask-address address nil names) program metadata names)
(signal 'no-show-row))
(defspecial interactive-quit
"Ask a yes-or-no question and, if yes, exit the program. I should make it prompt to save, later."
(cond ((ask-yes-or-no "Certainly exit the program? " names) (reset) (quit))))
(defspecial interactive-metaclear ;I should later write this so that INTERACTIVE-CLEAR might use it.
"Clear only the metadata contents of the current address. Labels are still unaffected."
(let ((type (aref (metadata-type metadata) address)))
(setf (aref (metadata-names metadata) address) 0
(aref (metadata-type metadata) address) (if (eq :octet type) :octet :instruction)
(aref (metadata-association metadata) address) :none)
(if (not (eq :octet type))
(setf (aref (metadata-names metadata) (1+ address)) 0
(aref (metadata-type metadata) (1+ address)) :subordinate
(aref (metadata-association metadata) (1+ address)) :none))))
(defspecial interactive-clear
"Clear the contents of the current address in every way to the system. Labels are unaffected."
(let ((type (aref (metadata-type metadata) address)))
(setf (aref program address) 0
(aref (metadata-names metadata) address) 0
(aref (metadata-type metadata) address) (if (eq :octet type) :octet :instruction)
(aref (metadata-association metadata) address) :none)
(if (not (eq :octet type))
(setf (aref program (1+ address)) 0
(aref (metadata-names metadata) (1+ address)) 0
(aref (metadata-type metadata) (1+ address)) :subordinate
(aref (metadata-association metadata) (1+ address)) :none))))
(defspecial up
"Move to the following row, scrolling if necessary."
(declare (special current-row current-address top-address))
(let ((do (= 1 current-row)))
(assert (= address current-address))
(if (zerop address) (return-from up (signal 'no-show-row)))
(setq current-row (max 1 (1- current-row))
current-address (backtrack current-address metadata) ;Make NO-SHOW-ROW conditional, later.
top-address (if do current-address top-address))
(cond (do (scroll :down) (show-row current-address program metadata names)))
(setf (cursor) (cons current-row row-home))
(signal 'no-show-row)))
(defspecial down
"Move to the preceding row, scrolling if necessary."
(declare (special current-row current-address top-address))
(let ((do (= rows current-row)))
(assert (= address current-address))
(if (zerop (fronttrack current-address metadata)) (return-from down (signal 'no-show-row)))
(setq current-row (min rows (1+ current-row))
current-address (fronttrack current-address metadata) ;Make NO-SHOW-ROW conditional later.
top-address (if do (fronttrack top-address metadata) top-address))
(cond (do (scroll :up) (show-row current-address program metadata names)))
(setf (cursor) (cons current-row row-home))
(signal 'no-show-row)))
(defspecial interactive-convert
"This command converts a program unit between an instruction and two octets.
This command previously cycled through instruction, hextet, and two octets.
This was prone to confusion. Now INTERACTIVE-VALUE is used to get hextets."
(declare (special current-row top-address))
(case #0=(aref (metadata-type metadata) address)
((:instruction :hextet) (setf #0# :octet
#1=(aref (metadata-type metadata) (1+ address)) :octet))
(:octet (if (ignore-errors (eq :octet #1#))
(setf #0# :instruction #1# :subordinate)
(return-from interactive-convert))))
(redraw-display current-row top-address program metadata names)
(signal 'no-show-row))
(defspecial interactive-value
"This command permits replacing instruction with hextet, or giving an octet or hextet new values."
(prepare-for-question)
(write-string "Value ")
(case #0=(aref (metadata-type metadata) address)
((:hextet :instruction)
(multiple-value-bind (integer name)
(read-integer 65535 (dpb (aref program address) (byte 8 8) (aref program (1+ address)))
(and (eq #0# :hextet)
(eq :hextet (aref (metadata-association metadata) address))
(aref names (aref (metadata-names metadata) address)))
names)
(setf (aref program address) (ldb (byte 8 8) integer)
(aref program (1+ address)) (ldb (byte 8 0) integer)
(aref (metadata-names metadata) address) (resolve-name-code name names)
(aref (metadata-association metadata) address) (if name :hextet :none)
(aref (metadata-names metadata) (1+ address)) 0
(aref (metadata-association metadata) (1+ address)) :none
#0# :hextet)))
(:octet (multiple-value-bind (integer name)
(read-integer 255 (aref program address)
(if (eq :octet (aref (metadata-association metadata) address))
(aref names (aref (metadata-names metadata) address)))
names)
(setf (aref program address) integer
(aref (metadata-names metadata) address) (resolve-name-code name names)
(aref (metadata-association metadata) address) (if name :octet :none))))))
(defun insert (address count program metadata names &aux (do (+ count address)))
"Insert COUNT units beginning at the address."
(if (eq :subordinate (aref (metadata-type metadata) address))
(error "INSERT has been called on a subordinate boundary."))
(cond ((not (zerop count))
(replace program program :start1 do :start2 address)
(replace #1=(metadata-type metadata) #1# :start1 do :start2 address)
(replace #2=(metadata-association metadata) #2# :start1 do :start2 address)
(replace #3=(metadata-names metadata) #3# :start1 do :start2 address)
(loop :for even := t :then (not even) :for nth :from address :below do
:do (setf (aref #1# nth) (if even :instruction :subordinate))) ;COUNT's even for now.
(fill program 0 :start address :end do)
(fill #2# :none :start address :end do)
(fill #3# 0 :start address :end do)
(if (member (aref #1# 4095) '(:instruction :hextet) :test 'eq) ;This edge case is required.
(setf (aref #1# 4095) :octet ;A split two units are appropriately transformed for this.
(aref #2# 4095) (getf '(:address :lower-nibble :hextet :octet)
(aref #2# 4095) (aref #2# 4095))))
(loop :for name :across names
:doing (and (name-label-p name)
(<= address (name-value name))
(let ((integer (+ count (name-value name))))
(if (>= 4095 integer)
(change-name integer (name-id name) t names metadata program)
(delete-name name names metadata)))))
(normalize-labels names))))
(defun delete (address count program metadata names &aux (do (+ count address)) (ed (- 4096 count)))
"Delete COUNT units beginning at the address."
(if (eq :subordinate (aref (metadata-type metadata) address))
(error "DELETE has been called on a subordinate boundary."))
(cond ((not (zerop count))
(replace program program :start1 address :start2 do)
(replace #1=(metadata-type metadata) #1# :start1 address :start2 do)
(replace #2=(metadata-association metadata) #2# :start1 address :start2 do)
(replace #3=(metadata-names metadata) #3# :start1 address :start2 do)
(loop :for even := t :then (not even) :for nth :from ed :below 4096
:do (setf (aref #1# nth) (if even :instruction :subordinate))) ;This, as with INSERT.
(fill program 0 :start ed) ;The corresponding edge case of insertion doesn't affect DELETE.
(fill #2# :none :start ed) ;There's a mere cosmetic edge case regarding :OCTET propagation.
(fill #3# 0 :start ed)
(if (member (aref #1# 4095) '(:instruction :hextet) :test 'eq) ;Here's that mentioned case.
(setf (aref #1# 4095) :octet)) ;An :OCTET is propagated; they should later be combined.
(loop :for name :across names
:doing (and (name-label-p name) ;reverse order, newer labels overwrite
(<= address (name-value name))
(let ((integer (- (name-value name) count)))
(if (<= address integer)
(change-name integer (name-id name) t names metadata program)
(delete-name name names metadata)))))
(normalize-labels names))))
(defspecial interactive-insert
""
(declare (special current-row top-address instruction))
(prepare-for-question)
(write-string "Instruction insertion count ")
(let ((integer (read-integer #0=(floor (- 4096 address) 2) (min #0# 1) nil names)))
(if (zerop integer)
(return-from interactive-insert)
(insert address (* 2 integer) program metadata names)))
;The following IFs are awful hacks for what I've stumbled across, as my INSTRUCTION model is poor.
(and #1=(N1 instruction) (<= address (name-value #1#)) (setf #1# nil (A1 instruction) :none))
(and #2=(N2 instruction) (<= address (name-value #2#)) (setf #2# nil (A2 instruction) :none))
(redraw-display current-row top-address program metadata names))
(defspecial interactive-delete
""
(declare (special current-row top-address instruction))
(prepare-for-question)
(write-string "Unit deletion count ") ;It's wasteful that I collect this limit, using this method.
(let* ((max (loop :for return := (fronttrack address metadata) :then (fronttrack return metadata)
:until (zerop return) :sum 1))
(integer (read-integer max (min max 1) nil names)))
(if (zerop integer)
(return-from interactive-delete)
(delete address (- (fronttrack address metadata integer) address) program metadata names)))
;The following IFs are awful hacks for what I've stumbled across, as my INSTRUCTION model is poor.
(and #1=(N1 instruction) (<= address (name-value #1#)) (setf #1# nil (A1 instruction) :none))
(and #2=(N2 instruction) (<= address (name-value #2#)) (setf #2# nil (A2 instruction) :none))
(redraw-display current-row top-address program metadata names))
(defun show-octet-with-name-association (octet association)
"Display the octet with the name association according to NAME-HEXTET-DISPLAY-PROPERTY."
(ecase association
(:none (format t "~2,'0X" octet))
((:octet :hextet) (setf (properties) name-hextet-display-property)
(format t "~2,'0X" octet))
(:upper-nibble (setf (properties) name-hextet-display-property)
(write-char (digit-char (ldb (byte 4 4) octet) 16))
(setf (properties) :default) (use-color :blue)
(write-char (digit-char (ldb (byte 4 0) octet) 16)))
((:lower-nibble :address) (write-char (digit-char (ldb (byte 4 4) octet) 16))
(setf (properties) name-hextet-display-property)
(write-char (digit-char (ldb (byte 4 0) octet) 16)))))
;This is unnecessary, I dislike single-use functions, but now I've already gone and written it here.
(defun show-hextet-with-name-associations (hextet first second)
"Display the hextet with the name associations according to NAME-HEXTET-DISPLAY-PROPERTY."
(show-octet-with-name-association (ldb (byte 8 8) hextet) first)
(setf (properties) :default) (use-color :blue) ;These are wasteful, but I'm too lazy to fix these.
(show-octet-with-name-association (ldb (byte 8 0) hextet)
(case first ((:address :hextet) :octet) (t second))))
(defun show-row (address program metadata names &aux (type (aref (metadata-type metadata) address))
(association (metadata-association metadata)))
""
(if (eq :subordinate type) (error "SHOW-ROW has been called on a subordinate boundary."))
(carriage-return)
(use-color :green)
(format t "~3,'0X~:[-~3,'0X~; ~] " address (eq :octet type) (1+ address))
(use-color :red)
(format t "~4,'0D~:[-~4,'0D~; ~] " address (eq :octet type) (1+ address))
(use-color :blue)
(let ((value (case type (:octet (aref program address))
((:instruction :hextet) (dpb (aref program address) (byte 8 8)
(aref program (1+ address)))))))
(cond ((eq :octet type)
(loop :for count :from 7 :downto 0 :for bit := (ldb (byte 1 count) value)
:do (write-char (char #+unicode " █" #-unicode " #" bit)))
(write-string " ") ;I suppose this part of the code has grown quite large and unwieldy.
(show-octet-with-name-association value
(if (and (not (zerop address))
(member (aref association (1- address))
'(:address :hextet)))
:octet (aref association address))))
(t (loop :for count :from 7 :downto 0
:for first := (ldb (byte 1 (+ 8 count)) value)
:for second := (ldb (byte 1 count) value)
:do (write-char (char #+unicode " ▄▀█" #-unicode " _^#"
(dpb first (byte 1 1) second))))
(write-char #\space)
(show-hextet-with-name-associations value (aref association address)
(aref association (1+ address)))))
(setf (properties) :default) (use-color :blue)
(format t " ~:[~5,'0D~; ~3,'0D~]" (eq :octet type) value))
(let ((first (resolve-label-value address names)) ;The overflow will be tolerated.
(second (if (not (eq type :octet)) (resolve-label-value (1+ address) names))))
(cond ((and first second) (use-color :yellow) (format t "+~15@A" (name-id first)))
(first (use-color :yellow) (format t "~16@A" (name-id first)))
(second (use-color '(:rgb 255 127 63)) (format t "!~15@A" (name-id second)))
(t (format t "~16@A" ""))))
(use-color :default)
(write-char #\space) ;Have code for distinguishing instructions with names here, at a later point.
(cond ((eq :instruction type)
(display-instruction (extract-instruction address program metadata names)))
((eq type (aref association address)) ;I exploit the intersection of associations and types.
(unwind-protect (progn (setf (properties) :underlined)
(write-string (name-id (aref names (aref (metadata-names metadata)
address)))))
(setf (properties) :default))))
(erase-in-line))
(defun redraw-display (current-row address program metadata names
&aux dimensions (current-address address))
""
(unwind-protect ;This UNWIND-PROTECT exists solely to handle the cursor hiding logic now embedded.
(progn (reset-mode '(#\? 25)) ;This hides the cursor to be later restored, due to DIMENSIONS.
(setf (cursor) nil ;Erasing the screen isn't needed. Recollect the screen dimensions.
dimensions (dimensions)) ;This following AND handles screen resizing edge cases.
(and dimensions (<= 100 (cdr dimensions)) (setq rows (first dimensions)))
(setq current-row (min rows current-row))
(if (eq :subordinate (aref (metadata-type metadata) address)) (decf address))
(loop :for count :from 1 :to rows
:do (if (= count current-row) (setq current-address address))
(show-row address program metadata names)
(setq address (fronttrack address metadata))
(if (zerop address) (loop-finish)) ;Stop redisplaying upon address wrapping.
(if (/= count rows) (line-feed)))
(erase-in-page) ;This handles any queer resizing edge cases, and works with the ZEROP.
(setf (cursor) (cons current-row row-home)))
(set-mode '(#\? 25))
(finish-output))
current-address)
(defun update-name (name namespace metadata program &aux (position (position name namespace)))
"After a name is already modified, this function will update all of its uses, by association."
(if (zerop position) (return-from update-name)) ;This parameter ordering could likely be improved.
(dotimes (count 4096)
(if (= position (aref (metadata-names metadata) count))
(setf #0=(aref program count) ;I would once remember these, but now redisplay is made cheap.
(ecase (aref (metadata-association metadata) count)
(:none #0#)
(:lower-nibble (dpb (name-value name) (byte 4 0) #0#))
(:upper-nibble (dpb (name-value name) (byte 4 4) #0#))
(:octet #1=(ldb (byte 8 0) (name-value name)))
(:address #2=(setf (aref program (1+ count)) #1#) ;Using 1+ now should be fine.
(dpb (ldb (byte 4 8) (name-value name)) (byte 4 0) #0#))
(:hextet #2# (ldb (byte 8 8) (name-value name))))))))
(defun create-name (value id label-p namespace)
"Add a name to the namespace, returning NIL if the namespace is full or the name, otherwise.
If a label is created, any already existing label for the value is modified.
This should be used solely from CHANGE-NAME, which handles more edge cases."
(declare (type (unsigned-byte 16) value) (type string id) (type boolean label-p))
(setq label-p (and label-p (> 4096 value)))
(if (zerop (length id))
(aref namespace 0)
(if (vector-push (make-name value id label-p) namespace)
(progn (if label-p (dotimes (count (1- (length namespace)))
(let ((name (aref namespace count)))
(and (name-label-p name)
(= value (name-value name))
(setf (name-label-p name) nil)))))
(aref namespace (1- (fill-pointer namespace)))))))
(defun normalize-labels (namespace)
"Labels must not share values, and this procedure removes the label status from any such matches.
This function was originally part of CHANGE-NAME; it exposed a poor edge case in INSERT and DELETE."
(loop :for name :across namespace ;This is unfortunately an algorithm having an O(N*N) complexity.
:if (name-label-p name)
:do (loop :for second :across namespace
:if (and (name-label-p second)
(not (eq name second))
(= (name-value name) (name-value second)))
:do (setf (name-label-p name) nil (name-label-p second) nil))))
(defun change-name (value id label-p namespace metadata program ;The latter two are for UPDATE-NAME.
&aux (position (position id namespace :key 'name-id :test 'string=)))
"Add a name to the namespace, changing any already existing name with the same ID.
If the namespace is full and a name is to be created anew, NIL is returned or the name, otherwise.
This function uses CREATE-NAME in the case the name isn't modified, but added anew."
(declare (type (unsigned-byte 16) value) (type string id) (type boolean label-p))
(setq label-p (and label-p (> 4096 value))) ;I may later need a CHANGE-NAME-ID as well, I suppose.
(if (zerop (length id))
(aref namespace 0)
(if position
(progn (setf (name-value #0=(aref namespace position)) value
(name-label-p #0#) label-p)
(update-name #0# namespace metadata program)
#0#)
(create-name value id label-p namespace))))
(defun delete-name (name namespace metadata &aux (position (position name namespace)))
"Delete the name from the namespace, sans zeroeth, removing all metadata association information."
(or position (error "Invalid name ~A has been used in ~A." (name-id name) 'delete-name))
(cond ((zerop position))
(t (nsubstitute 0 position (metadata-names metadata) :test '=)
(setf (aref namespace position) (vector-pop namespace))
(nsubstitute position (length namespace) (metadata-names metadata) :test '=)
(loop :for count :from 0 :to (1- (length (metadata-names metadata)))
:do (if (zerop (aref (metadata-names metadata) count))
(setf (aref (metadata-association metadata) count) :none))))))
(defun automatic-association (name program metadata names &aux (position (position name names)))
"Associate all instructions without such name associations which match the provided name with it."
(if (zerop position) (return-from automatic-association))
(or position
(require-acknowledgement "An invalid name was somehow provided.")
(return-from automatic-association))
(prog (instruction (aref 0)) :start
(cond ((setq instruction (extract-instruction aref program metadata names))
(case (C instruction)
((0 1 2 #xA #xB)
(if (name-label-p name)
(cond ((and (zerop (C instruction))
(eql (A2 instruction) :none)
(or (= #xC (ldb (byte 8 4) (XXX instruction)))
(= #xD (ldb (byte 8 4) (XXX instruction))))
(= (name-value name) (ldb (byte 4 0) (XXX instruction))))
(setf (A2 instruction) :lower-nibble (N2 instruction) name))
((and (eql (A1 instruction) :none)
(= (name-value name) (XXX instruction)))
(setf (A1 instruction) :address (N1 instruction) name)))))
((3 4 6 7 #xC)
#0=(if (and (eql (A1 instruction) :none)
(= (name-value name) (X instruction)))
(setf (A1 instruction) :lower-nibble (N1 instruction) name))
(if (and (eql (A2 instruction) :none)
(= (name-value name) (YY instruction)))
(setf (A2 instruction) :octet (N2 instruction) name)))
((#xE #xF) #0#)
((5 8 9) #0#
#1=(if (and (eql (A2 instruction) :none)
(= (name-value name) (Y instruction)))
(setf (A2 instruction) :upper-nibble (N2 instruction) name)))
(#xD #0# ;Because of the inadequate internal representation, this is awkward, here.
(if (eql (A2 instruction) :none)
(cond ((= (name-value name) (Y instruction))
(setf (A2 instruction) :upper-nibble (N2 instruction) name))
((= (name-value name) (Z instruction))
(setf (A2 instruction) :lower-nibble (N2 instruction) name))))))
(deposit-instruction aref program metadata names instruction)))
(setq aref (fronttrack aref metadata))
(or (zerop aref) (go :start))))
(defspecial interactive-automatic-association
"Interactively prompt for a name, and automatically create associations across the program.
This command currently only works for names which are label."
(prepare-for-question)
(write-string "Name to find associations thereto ")
(automatic-association (read-name-id names) program metadata names)
(redraw-display current-row top-address program metadata names))
(defspecial interactive-note
(prepare-for-question)
(require-acknowledgement (map 'string 'code-char ;Unfortunately, this but works properly in ASCII.
#(70 101 101 108 32 99 108 101 118 101 114 63 32))))
(defspecial interactive-change-name
"Interactively prompt for a name, not label, modifying an already existing name or creating anew."
(declare (special instruction))
(prepare-for-question)
(write-string "Name to change or create ")
(let ((name (read-string)))
(if (zerop (length name)) (return-from interactive-change-name))
(prepare-for-question)
(write-string name)
(write-string " value ")
(let* ((name-id (resolve-name-id name names))
(name (change-name (read-integer 65535 (if name-id (name-value name-id) 0) nil names)
name nil names metadata program)))
(cond (name (if (equalp name (N1 instruction)) ;I'll properly correct these name slots, later.
(setf (N1 instruction) nil (A1 instruction) :none))
(if (equalp name (N2 instruction))
(setf (N2 instruction) nil (A2 instruction) :none)))
(t (require-acknowledgement "The namespace is full.")))))
(normalize-labels names)
(redraw-display current-row top-address program metadata names)
(signal 'no-show-row))
(defspecial interactive-change-label
"Interactively prompt for a name and use it to denote a label, modifying any which already exist."
(declare (special instruction))
(prepare-for-question)
(write-string "Label name ")
(let ((name (change-name address (read-string) t names metadata program)))
(cond (name (if (equalp name (N1 instruction))
(setf (N1 instruction) nil (A1 instruction) :none))
(if (equalp name (N2 instruction))
(setf (N2 instruction) nil (A2 instruction) :none)))
(t (require-acknowledgement "The namespace is full."))))
(normalize-labels names)
(redraw-display current-row top-address program metadata names)
(signal 'no-show-row))
(defspecial interactive-delete-name
"Interactively prompt for a name and, if it exists and isn't that zeroeth, erase it and its uses."
(declare (special instruction))
(prepare-for-question)
(write-string "Name to delete ")
(let* ((name (read-name-id names)))
(delete-name name names metadata) ;DELETE-NAME will handle that zeroeth name specially; I won't.
(if (equalp name (N1 instruction)) (setf (N1 instruction) nil (A1 instruction) :none))
(if (equalp name (N2 instruction)) (setf (N2 instruction) nil (A2 instruction) :none)))
(redraw-display current-row top-address program metadata names)
(signal 'no-show-row))
(defspecial interactive-delete-label
"Delete the label, if any, present at the current location." ;Delete a name at (1+ ADDRESS) later.
(declare (special instruction))
(let* ((name (or (resolve-label-value address names)
(and (member (aref (metadata-type metadata) address) '(:instruction :hextet))
(resolve-label-value (1+ address) names))
(return-from interactive-delete-label))))
(delete-name name names metadata)
(if (equalp name (N1 instruction)) (setf (N1 instruction) nil (A1 instruction) :none))
(if (equalp name (N2 instruction)) (setf (N2 instruction) nil (A2 instruction) :none)))
(redraw-display current-row top-address program metadata names)
(signal 'no-show-row))
(defspecial interactive-extended
"Due to the constraints of the MMC keyboard interface, this is a ``grab-bag'' of miscellany."
(tagbody :start
(cond ((ask-yes-or-no "Change the identifier of a name? " names)
(prepare-for-question)
(write-string "Name identifier to change ")
(let ((name (read-name-id names)))
(cond ((zerop (length (name-id name)))
(require-acknowledgement "That isn't allowed.")
(return-from interactive-extended)))
(prepare-for-question)
(write-string "New name identifier ")
(let ((string (read-string)))
(cond ((zerop (length string))
(require-acknowledgement "That isn't allowed.")
(return-from interactive-extended))
((resolve-name-id string names)
(require-acknowledgement "That name identifier is already used.")
(return-from interactive-extended)))
(setf (name-id name) string)
(redraw-display current-row top-address program metadata names)
(signal 'no-show-row)))))
(go :start)))
(defun interactive-repeat (instruction namespace subst) ;I was considering mine MMC, and assemblers.
"This simple little function merely repeats the previous instruction, as a potential convenience."
(declare (ignore namespace subst)) ;Now it's quite easy to ``copy'', or ``paste'', blocks of code.
instruction)
(defun list-all-names (program metadata names) ;The function's body is from INTERACTIVE-DELETE-NAME.
"This interface function exists to show all names, and allows them to be deleted if desired."
(declare (special current-row top-address instruction))
(require-acknowledgement "All names will be listed; answer yes to delete one.")
(loop :for name :across (subseq names 1) ;This works because SUBSEQ creates a copy of this vector.
:doing (if (ask-yes-or-no (format nil "Name ~15@A ~4,'0X~:* ~5,'0D is~:[ not~;~] a label. "
(name-id name) (name-value name) (name-label-p name))
names)
(progn (delete-name name names metadata)
(if (equalp name (N1 instruction))
(setf (N1 instruction) nil (A1 instruction) :none))
(if (equalp name (N2 instruction))
(setf (N2 instruction) nil (A2 instruction) :none)))))
;(redraw-display current-row top-address program metadata names) (signal 'no-show-row)
)
(defun show-as-html (first last program metadata names &optional (stream *standard-output*)
&aux (*standard-output* stream))
"This function isn't used by the MMC, existing purely so I may easily produce HTML for my writing.
I strongly dislike HTML, as with the rest of the WWW filth, but this is the easiest method for such.
Unlike the rest of the MMC, be warned I may choose to make little effort for exceptional situations.
That HTML generated will still require some manual adjustments; it's expected to be styled this way:
.h{color:#4E9A06}.d{color:#CD0404}.v{color:#3465A4}.l{color:#C4A000}.m{color:#FF7F3F}
.r{color:#2E3436}"
(if (eq :subordinate (aref (metadata-type metadata) first)) (decf first))
(write-string "")
(loop :with address := first
:for type := (aref (metadata-type metadata) address)
:for association := (aref (metadata-association metadata) address)
:until (> address last)
:doing (write-string "")
(format t "~3,'0X~:[-~3,'0X~; ~] " address (eq :octet type) (1+ address))
(write-string "")
(format t "~4,'0D~:[-~4,'0D~; ~] " address (eq :octet type) (1+ address))
(write-string "")
(let ((value (case type (:octet (aref program address))
((:instruction :hextet) (dpb (aref program address) (byte 8 8)
(aref program (1+ address)))))))
(cond ((eq :octet type)
(loop :for count :from 7 :downto 0 :for bit := (ldb (byte 1 count) value)
:do (write-char (char #+unicode " █" #-unicode " #" bit)))
(write-string " ")
(format t (ecase (if (and (not (zerop address))
(member (aref (metadata-association metadata)
(1- address))
'(:address :hextet)))
:octet association)
(:none "~2,'0X")
((:octet :hextet) "~2,'0X")
(:upper-nibble "~*~1,'0X~1,'0X")
((:lower-nibble :address) "~*~1,'0X~1,'0X"))
value (ldb (byte 4 0) value) (ldb (byte 4 4) value)))
(t (loop :for count :from 7 :downto 0
:for first := (ldb (byte 1 (+ 8 count)) value)
:for second := (ldb (byte 1 count) value)
:do (write-char (char #+unicode " ▄▀█" #-unicode " _^#"
(dpb first (byte 1 1) second))))
(write-char #\space)
(format t (ecase association ;I don't currently need those others, at all.
(:none "~4,'0X")
(:address "~*~1,'0X~3,'0X"))
value (ldb (byte 4 12) value) (ldb (byte 12 0) value))))
(format t " ~:[~5,'0D~; ~3,'0D~]" (eq :octet type) value))
(write-string "")
(let ((first (resolve-label-value address names))
(second (if (not (eq type :octet)) (resolve-label-value (1+ address) names))))
(cond ((and first second) (format t "+~15@A~
" (name-id first)))
(first (format t "~16@A"
(name-id first)))
(second (format t "!~15@A"
(name-id second)))
(t (format t "~16@A" ""))))
(write-char #\space)
(cond ((eq :instruction type) ;Rebind DISPLAY-NAME here.
(display-instruction (extract-instruction address program metadata names)))
((eq type (aref (metadata-association metadata) address))
(progn (write-string "")
(write-string (name-id (aref names (aref (metadata-names metadata)
address))))
(write-string ""))))
(write-string "")
(write-char #\return)
(write-char #\linefeed)
(setq address (fronttrack address metadata)))
(write-string "
")
(values))
(defparameter table (let ((hash-table (make-hash-table :size 128 :rehash-threshold 1)))
(map nil (lambda (acons) (setf (gethash (car acons) hash-table) (cdr acons)))
#+qwerty
'((#\q . make-1XXX) (#\w . make-2XXX) (#\e . make-AXXX) (#\r . make-BXXX)
(#\t . make-DXYZ) (#\f . make-CXYY) (#\u . make-3XYY) (#\i . make-4XYY)
(#\o . make-6XYY) (#\p . make-7XYY) (#\Q . make-EX9E) (#\W . make-EXA1)
(#\E . make-FX07) (#\R . make-FX0A) (#\T . make-FX15) (#\Y . make-FX18)
(#\U . make-FX1E) (#\I . make-FX29) (#\O . make-FX30) (#\P . make-FX33)
(#\[ . make-FX55) (#\] . make-FX65) (#\{ . make-FX75) (#\} . make-FX85)
(#\z . make-5XY0) (#\x . make-8XY0) (#\c . make-8XY1) (#\v . make-8XY2)
(#\b . make-8XY3) (#\n . make-8XY4) (#\m . make-8XY5) (#\, . make-8XY6)
(#\\ . make-8XY7) (#\. . make-8XYE) (#\/ . make-9XY0) (#\Z . make-0XXX)
(#\X . make-00E0) (#\C . make-00EE) (#\V . make-00FB) (#\B . make-00FC)
(#\N . make-00FD) (#\M . make-00FE) (#\< . make-00FF) (#\> . make-00CX)
(#\? . make-00DX)
(#\k . interactive-change-name) (#\K . interactive-delete-name)
(#\l . interactive-change-label) (#\L . interactive-delete-label)
(#\a . interactive-insert) (#\A . interactive-delete)
(#\j . interactive-value) (#\J . interactive-convert)
(#\g . less-interactive-save)
(#\h . interactive-only-instate) ;(#\H . interactive-higher-instate)
(#\: . interactive-automatic-association)
(#\s . up) (#\d . down) (#\f . interactive-jump))
#-qwerty
'((#\' . make-1XXX) (#\, . make-2XXX) (#\. . make-AXXX) (#\p . make-BXXX)
(#\y . make-DXYZ) (#\f . make-CXYY) (#\g . make-3XYY) (#\c . make-4XYY)
(#\r . make-6XYY) (#\l . make-7XYY) (#\" . make-EX9E) (#\< . make-EXA1)
(#\> . make-FX07) (#\P . make-FX0A) (#\Y . make-FX15) (#\F . make-FX18)
(#\G . make-FX1E) (#\C . make-FX29) (#\R . make-FX30) (#\L . make-FX33)
(#\/ . make-FX55) (#\= . make-FX65) (#\? . make-FX75) (#\+ . make-FX85)
(#\; . make-5XY0) (#\q . make-8XY0) (#\j . make-8XY1) (#\k . make-8XY2)
(#\x . make-8XY3) (#\b . make-8XY4) (#\m . make-8XY5) (#\w . make-8XY6)
(#\\ . make-8XY7) (#\v . make-8XYE) (#\z . make-9XY0) (#\: . make-0XXX)
(#\Q . make-00E0) (#\J . make-00EE) (#\K . make-00FB) (#\X . make-00FC)
(#\B . make-00FD) (#\M . make-00FE) (#\W . make-00FF) (#\V . make-00CX)
(#\Z . make-00DX)
(#\t . interactive-change-name) (#\T . interactive-delete-name)
(#\n . interactive-change-label) (#\N . interactive-delete-label)
(#\a . interactive-insert) (#\A . interactive-delete)
(#\h . interactive-value) (#\H . interactive-convert)
(#\i . less-interactive-save)
(#\d . interactive-only-instate) ;(#\D . interactive-higher-instate)
(#\S . interactive-automatic-association)
(#\o . up) (#\e . down) (#\u . interactive-jump)))
(map nil (lambda (acons) (setf (gethash (car acons) hash-table) (cdr acons)))
'(#+delete (#.(or (name-char "rubout") (code-char 127)) . interactive-metaclear)
#-delete (#.(or (name-char "rubout") (code-char 127)) . interactive-clear)
(#.(or (name-char "backspace") (code-char 8)) . interactive-clear)
(#\newline . interactive-repeat) (#\_ . interactive-extended)
(#.(or (name-char "return") (code-char 13)) . interactive-repeat)
(#.(or (name-char "linefeed") (code-char 10)) . interactive-repeat)
(#.(or (name-char "null") (code-char 0)) . interactive-note)
(#.(or (name-char "escape") (code-char 27)) . interactive-quit)))
hash-table)
"This is a hash table containing the associations between characters and commands.")
(defun prime (&aux read (metadata (make-metadata)) (current-row 1) (current-address 512)
(instruction (make-instruction))
(program (make-array 4096 :element-type 'octet :initial-element 0))
(namespace (make-array 2048 :element-type 'name :adjustable t :fill-pointer 1
:initial-element (make-name 0 ""))))
""
(declare (special instruction)) ;This is required, for those name-manipulation procedures to work.
(create-name 0 "no" nil namespace) ;I've decided it's reasonable to include these two, by default.
(create-name 1 "yes" nil namespace) ;I may later have these made conditional for anyone who cares.
;The following code exists to enable me to easily collect the display of the MMC, for my writings.
#+(or) (dribble (make-pathname :directory #+unix '(:absolute "tmp") #-unix ()
:name "mmc-dribble" :version :newest
:defaults *default-pathname-defaults*))
(jump current-address program metadata namespace)
(loop (setq read (ignore-errors (read-event))) ;The IGNORE-ERRORS is temporary until I update ATC.
(cond ((characterp read) ;This is the case of the prime loop handling common keyboard input.
(let* ((function (gethash read table))
(special-operator-p (if function (get function :special)))
(redraw-display (if special-operator-p nil
(ignore-errors (eq :octet (aref (metadata-type metadata)
(1+ current-address)))))))
(if function
(handler-case ;My handler cases could be much better, so unfortunate presently.
(cond (special-operator-p
(funcall function current-address program metadata namespace))
(t (prepare-for-question)
(deposit-instruction
current-address program metadata namespace
(setq instruction
(funcall function instruction namespace
(extract-instruction current-address program
metadata namespace))))))
(no-show-row ())
(refuse-to-answer ()
#0=(cond (redraw-display (redraw-display current-row top-address
program metadata namespace))
(t (show-row current-address program metadata namespace)
(setf (cursor) (cons current-row row-home)))))
(serious-condition (condition)
(block nil
(if (ask-yes-or-no "The MMC has encountered a serious flaw. Show it? "
namespace)
(restart-case (invoke-debugger condition) ;This is fine as it's rare.
(continue () :report "Ignore the flaw and continue."
(jump top-address program metadata namespace) (return)))
#0#)))
#2=(:no-error (&rest rest) (declare (ignore rest)) #0#)))))
((and (consp read) (eq :mouse (first read))) ;This handles all of the mouse inputting.
(block nil
(let ((row (fourth read)))
(cond ((< 2047 row) (return)) ;Mouse clicks won't work if the screen is too tall.
((> current-row row)
(setq current-address
(backtrack current-address metadata (- current-row row))))
((< current-row row)
(setq current-address
(if (> current-address ;This became poor, when I saw this edge case.
#1=(fronttrack current-address metadata (- row current-row)))
(return)
#1#))))
(setq current-row row)
(if (= 3 (second read))
(jump current-address program metadata namespace)
(setf (cursor) (cons current-row row-home))))))
((and (consp read) (eq :meta (first read))) ;This handles all of those meta key codes.
(let ((character (cdr read)))
(handler-case (case character
(#\s (list-all-names program metadata namespace)))
(refuse-to-answer ())
(:no-error (&rest rest) (declare (ignore rest))))
(redraw-display current-row top-address program metadata namespace)))
(t (case read ;This case handles those miscellaneous keys, and the mouse scroll wheel.
((:up :scroll-up) (up current-address program metadata namespace))
((:down :scroll-down) (down current-address program metadata namespace))
((:start :end) (jump (if (eq read :start) 512 (backtrack 4096 metadata rows))
program metadata namespace))
(:page-up (let ((address (backtrack top-address metadata rows)))
(jump (if (< top-address address) 0 address)
program metadata namespace)))
(:page-down (let ((address (fronttrack top-address metadata rows)))
(if (< top-address address)
(jump address program metadata namespace)))))))
(finish-output))
;Have case for program exit.
;Save program in failure case.
;In normal operation, this is never actually used.
(reset) (quit))
(prime)
.