code/interpreter.lisp (7752 bytes)
1 ;;;; Copyright (c) 2016 Spenser Truex 2 ;;;; Permission is hereby granted, free of charge, to any person obtaining a copy of this brainfuck software and associated 3 ;;;; documentation files (the "Brainfuck Software"), to deal in the Brainfuck Software without restriction, including without 4 ;;;; limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the 5 ;;;; Brainfuck Software, and to permit persons to whom the Brainfuck Software is furnished to do so, subject to the following 6 ;;;; conditions: 7 8 ;;;; The above copyright notice and this permission notice shall be included in all copies or substantial portions of this 9 ;;;;Brainfuck Software. 10 11 ;;;; THE BRAINFUCK SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED 12 ;;;; TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS 13 ;;;; OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 14 ;;;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THIS BRAINFUCK SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS 15 ;;;; BRAINFUCK SOFTWARE. 16 (in-package :brain) 17 18 ;;; All three of the following must be changed together for the desired effect 19 20 (define-condition infinite-loop-detected (condition) ()) 21 22 (defparameter *max-byte* 255) 23 (defparameter *min-byte* 0) 24 (defparameter *byte-element-type* '(unsigned-byte 8) 25 "Element type used in the tape array. By default an 8 bit unsigned byte is used.") 26 27 (defparameter *infinite-looping-allowed* 'nil 28 "Turn on or off infinite looping") 29 (defparameter *loop-limit* 9000 30 "Arbitrary limit to detect an infinite loop. May need to be adjusted for long-running programs") 31 (defvar *current-loop* 0 32 "Holds the current number of loops executed. Once it reaches *loop-limit* it will halt the program, unless *infinite-looping-allowed* is T") 33 34 (defparameter *tape-size-default* 30000 35 "The size of the tape, in bytes, used to store each byte") 36 37 (defvar *loop-depth* 0 38 "Used to provide an error for #f] and failures to open a loop") 39 40 (defvar *output* "" 41 "Defaults to an empty string because it is setf'd by other functions") 42 43 (defparameter *initial-element* 0 44 "initial value for inside the byte array") 45 46 (defparameter *separators* '(#\Newline #\Space #\)) 47 "#F notation separators. These can be changed to allow whitespace 48 comments or to break a right parentheses immediately to the right side") 49 50 (defparameter *unread-separators* '(#\)) 51 "#F notation separators that should be unread for use by other functions") 52 53 (defun make-tape-array () 54 "Creates a new tape array" 55 (make-array *tape-size-default* 56 :element-type *byte-element-type* 57 :initial-element *initial-element*)) 58 (defvar *tape* (make-tape-array) 59 "The tape array used to store each byte") 60 61 (defvar *brainfuck* "" 62 "Place to store brainfuck code input string globally") 63 64 (defun pointer-default () 65 "Get the value to set the pointer back to." 66 (floor (/ *tape-size-default* 2))) 67 68 (defvar *pointer* (pointer-default) 69 "The pointer location for the tape. Starts at the middle.") 70 71 (defvar *code-position* 0 72 "Holds the state of the pointer in the brainfuck ccode.") 73 74 (defparameter *operators* '((open-loop . #\[) ;Can signal an error, will need to be handled for a userless experience. 75 (close-loop . #\]) ;Also can signal an error 76 (right-shift . #\>) 77 (left-shift . #\<) 78 (print-this-byte . #\.) 79 (read-this-byte . #\,) 80 (incf-byte . #\+) 81 (decf-byte . #\-)) 82 "The operator's function name and it's character. Nothing is passed to the functions") 83 84 (defun reset-globals () 85 (setf *tape* (make-tape-array)) 86 (setf *brainfuck* "") 87 (setf *pointer* (pointer-default)) 88 (setf *output* "") 89 (setf *code-position* 0) 90 (setf *current-loop* 0) 91 (setf *loop-depth* 0)) 92 93 (defmacro byte-value () 94 `(aref *tape* *pointer*)) 95 96 (defmacro crement-if (operation 97 bound 98 bound-next) 99 "Increment or decrement a byte" 100 `(if (= (byte-value) ,bound) 101 (setf (byte-value) ,bound-next) 102 (,operation (byte-value)))) 103 104 (defun open-loop () 105 "Open a brainfuck loop with this function" 106 ;; For non-zero the loop will be executed naturally until the ], but for a zero the position must be skipped 107 (cond ((and (not *infinite-looping-allowed*) 108 (>= *current-loop* *loop-limit*)) 109 (error 'infinite-loop-detected)) 110 ((= 0 (byte-value)) (setf *code-position* 111 (1- (skip-loop *code-position*)))) 112 (t (progn (incf *current-loop*) 113 (incf *loop-depth*))))) 114 115 (defun close-loop () 116 (setf *code-position* 117 (1- (goto *code-position*))) 118 (decf *loop-depth*)) 119 120 (defun char->function (char) 121 (car (rassoc char *operators*))) 122 123 (defun name->char (name) 124 (cdr (assoc name *operators*))) 125 126 (defun this-code-character () 127 (elt *brainfuck* *code-position*)) 128 129 (defun one-off-fuck () 130 "Interpret a single brainfuck character and execute it." 131 (let ((function (char->function (this-code-character)))) 132 (if function 133 (funcall function)))) 134 135 (defun shorthand-fuck-aux (stream list) 136 "Recursive reader macro. A compiler from within Lisp!" 137 (let ((char (read-char stream nil nil))) 138 (if (or (any-char char *separators*) 139 (null char)) 140 (progn (when (any-char char *unread-separators*) 141 (unread-char char stream)) 142 (char-list->string (nreverse list))) 143 (shorthand-fuck-aux stream (push char list))))) 144 145 (defun shorthand-fuck (stream char subchar) 146 "This is a 'Reader Macro' that provides the #F notation" 147 (declare (ignore char subchar)) 148 (list 'fuck (shorthand-fuck-aux stream nil))) 149 (set-dispatch-macro-character #\# #\F #'shorthand-fuck) 150 151 (defun wrap-pointer () 152 (cond ((= *pointer* *tape-size-default*) (setf *pointer* 0)) 153 ((= *pointer* -1) (setf *pointer* (1- *tape-size-default*))))) 154 155 (defun incf-byte () 156 "Increment a byte, and wrap to 0 if 255 is incremented" 157 (crement-if incf *max-byte* *min-byte*)) 158 159 (defun decf-byte () 160 "Decrement a byte, and wrap to 255 if 0 is decremented" 161 (crement-if decf *min-byte* *max-byte*)) 162 163 (defun goto-aux (current-position 164 depth) 165 (let ((this (elt *brainfuck* current-position))) 166 (if (char= (name->char 'open-loop) this) 167 (if (= 1 depth) 168 current-position 169 (if (> depth 1) 170 (goto-aux (1- current-position) 171 (1- depth)) 172 (goto-aux (1- current-position) 173 0))) 174 (if (char= (name->char 'close-loop) this) 175 (goto-aux (1- current-position) 176 (1+ depth)) 177 (goto-aux (1- current-position) 178 depth))))) 179 180 (defun goto (position) 181 "Work backwards and find the matching open bracket." 182 (goto-aux position 0)) 183 184 (defun right-shift () 185 "Move to the next byte to the 'right'" 186 (incf *pointer*) 187 (wrap-pointer)) 188 189 (defun left-shift () 190 "Move to the next byte to the 'left'" 191 (decf *pointer*) 192 (wrap-pointer)) 193 194 (defun print-this-byte () 195 (setf *output* (concatenate 'string 196 *output* 197 (vector (integer->ascii (byte-value)))))) 198 199 (defun read-this-byte () 200 (setf (byte-value) 201 (ascii->integer (read-char)))) 202 203 (defun skip-loop-aux (position depth) 204 (let ((this (char *brainfuck* position))) 205 (if (char= (name->char 'open-loop) this) 206 (skip-loop-aux (1+ position) (1+ depth)) 207 (if (char= (name->char 'close-loop) this) 208 (if (= 1 depth) 209 (1+ position) 210 (skip-loop-aux (1+ position) (1- depth))) 211 (skip-loop-aux (1+ position) depth))))) 212 213 (defun skip-loop (position) 214 (skip-loop-aux position 0)) 215 216 (defun fuck (brainfuck-string) 217 "Interpret the brainfuck" 218 (reset-globals) 219 (setf *brainfuck* brainfuck-string) 220 ;; Loop over each character in the string 221 (loop until (= *code-position* (length *brainfuck*)) 222 do (one-off-fuck) 223 do (incf *code-position*)) 224 *output*)