Rosetta Code

Execute Brain****/Common Lisp: Difference between revisions

Page Discussion

Execute Brain****/Common Lisp (view source)

Revision as of 11:11, 1 September 2022

1,706 bytes added ,  1 year ago
m
Fixed syntax highlighting.
(Added proper catagory setting)
m (Fixed syntax highlighting.)
 
(11 intermediate revisions by 9 users not shown)
Line 1:
{{implementation|Brainf***}}{{collection|RCBF}}
=={{header|Common Lisp}}==
 
This is an implementation of [[Brainf***]] written in [[Common Lisp]].
(defstruct bf-state
 
(program)▼
<syntaxhighlight lang="lisp">(defstruct bf-state
(program-counter 0)
▲ (program)
(memory (make-array 1 :initial-element 0 :adjustable t))▼
(memoryprogram-pointercounter 0))
▲ (memory (make-array 1 :initial-element 0 :adjustable t))
(cond ((>= (bf-state-memory-pointer state0)▼
(stack))
 
(defmacro with-bf-slots ((program-sym program-counter-sym
(1+ (bf-state memory-sym memory-pointer state))-sym▼
old stack-memory)))))sym)▼
obj-expr &body body)
"Macro to replace cumbersome structure slot references with
local lexical macros resembling local variables."
`(symbol-macrolet ((,program-sym (bf-state-program ,obj-expr))
(incf,program-counter-sym (bf-state-program-counter state))),obj-expr))▼
(setf,memory-sym (bf-state-memory state,obj-expr))▼
(#\+ (incf (elt (bf,memory-statepointer-memory state)sym (bf-state-memory-pointer state)),obj-expr))▼
(setf (subseq,stack-sym (bf-state-memorystack state,obj-expr)) extent)▼
,@body))
 
(defun adjust-memory (state)
"Modifies memory and memory-pointer such that memory-pointer is
a valid index to the memory array. If it is too large, the array
is extended; if it is negative, the array is extended, its
contents are shifted forward and the memory-pointer is incremented,
by an amount to make the memory ."
(with-bf-slots (program pc mem ptr stack) state
(cond ((>= ptr (length mem))
(adjust-array mem (1+ ptr) :initial-element 0))
((placesminusp nil)ptr)▼
(let ((extent (- ptr)))
(princincf "BRAINFUCK>ptr "extent)▼
(make-arraylet (+ (length old-memory) extent(copy-seq mem)))▼
(setf mem (make-array (+ (length old-memory) extent)))
(setf (subseq mem extent) old-memory)))))))
(defun adjustmatching-memorybracket-for (stateprogram bracket-index)
(loop with depth = 1
▲ (cond ((>= (bf-state-memory-pointer state)
for index from (array-dimension1+ (bfbracket-state-memory state) 0)index)
when (adjust-array>= index (bf-state-memorylength stateprogram))
do (error "unmatched [ bracket")
▲ (1+ (bf-state-memory-pointer state))
do (case (aref program :initial-element 0)index)
((<#\[ (bf-state-memory-pointerincf statedepth) 0)
(let ((extent (-#\] (bf-state-memory-pointerdecf state)depth)))
until (incf (bf-state-memory-pointer state)zerop extentdepth)
(let ((old-memory (copy-seqfinally (bf-state-memoryreturn state)index)))
▲ (setf (bf-state-memory state)
▲ (make-array (+ (length old-memory) extent)))
▲ (setf (subseq (bf-state-memory state) extent)
▲ old-memory))))))
(defun brainfuck-eval (state &optional (stream *standard-output*))▼
(defun matching-bracket-for (program bracket-index)
(with-bf-slots (program pc mem ptr stack) state
(let ((depth 0))
(loop forwhile index(< := bracket-index thenpc (1+length indexprogram)) do
when (>= indexcase (lengtharef program) pc)
(#\+ (incf (aref mem do (error 'failptr)))
when (char= #\[- (decf (eltaref programmem indexptr)))
(#\> (incf doptr) (incfadjust-memory depthstate))
when (char= #\]< (eltdecf programptr) (adjust-memory indexstate))
(#\[ (if (/= do0 (decfaref mem depthptr))
until (push (=1- depthpc) 0stack)
finally (returnsetf pc (matching-bracket-for program indexpc))))
(#\] (setf pc (pop stack)))
(#\. (write-char (code-char (aref mem ptr)) stream)))
▲ (defun brainfuck-eval (state &optional (stream *standard-output*))
(let ((program (bf-state-programincf statepc))))
 
▲ (places nil))
(defun brainfuck-compile-guts (program &optional (start 0) (until-bracket nil))
(loop while (< (bf-state-program-counter state) (length program)) do
(loop for insn from start (casebelow (eltlength program (bf-state-program-counter state))
appending (case (aref program insn)
▲ (#\+ (incf (elt (bf-state-memory state) (bf-state-memory-pointer state))))
(#\-+ `(decf (eltincf (bf-state-memoryaref state) (bf-state-memory-pointermem stateptr))))
(#\>- `(incf(decf (bf-state-memory-pointeraref statemem ptr)) (adjust-memory state))
(#\<> `(decf (bf-state-memory-pointerincf state)ptr) (adjust-memory state)))
(#\[ (if (/= 0 (elt#\< `(bf-state-memory(decf stateptr) (bf-stateadjust-memory-pointer state)))
(push#\[ (1-let (bf(end (matching-statebracket-for program-counter stateinsn)) places)
(setf (bf-state-program-counterprog1 state)
(matching-bracket-for program `(bf-state-program-counter(do state)() ((= 0 (aref mem ptr)))
(#\] (setf ,@(bfbrainfuck-statecompile-guts program-counter state) (pop1+ insn) placesend)))
(#\. (write-char (code-char (elt (bf-state-memorysetf insn stateend))))
(#\] (if (bfuntil-state-memory-pointer state)))bracket
stream)) (if (= until-bracket insn)
(loop-finish)
▲ (incf (bf-state-program-counter state)))))
(error "internal problem matching brackets"))
▼
(error "extra ] bracket")))
(defun bf (program) (brainfuck-eval (make-bf-state :program program)))▼
(#\. `((write-char (code-char (aref mem ptr)) stream))))))
▲
(defun brainfuck-compile (program)
(compile nil `(lambda (&optional (stream *standard-output*))
(let ((state (make-bf-state :program ,program)))
(with-bf-slots (program pc mem ptr stack) state
,@(brainfuck-compile-guts program))
(values)))))
 
(defun bf (program)
(if (and (not (zerop (length program)))
(char= #\! (aref program 0)))
(funcall (brainfuck-compile program))
▲ (defun bf (program) (brainfuck-eval (make-bf-state :program program))))
(defun bf-repl ()
"read-eval-print loop for bf. Code prefixed with ! is compiled, otherwise interpreted"
(loop do (fresh-line)
▲ (princ "BRAINFUCK> ")
(brainfuck-evalprinc (make-bf-state"BRAINFUCK> :program (read-line))))")
(bf (read-line))))</syntaxhighlight>
PureFox
9,476

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/50448...329429"