fork download
  1. (defparameter *MEMORY-SIZE* 30000)
  2. (defparameter *COMMANDS* '((> inc-pointer)
  3. (< dec-pointer)
  4. (+ inc-value)
  5. (- dec-value)
  6. (\. putchar)
  7. (\, getchar)
  8. ([ loop-begin)
  9. (] loop-end)))
  10.  
  11. (defun file-to-list (file)
  12. (with-open-file (in file)
  13. (when in
  14. (loop for line = (read-line in nil)
  15. while line collect line))))
  16.  
  17. (defun collect-string (lst)
  18. (reduce #'(lambda (a b) (concatenate 'string a b)) lst))
  19.  
  20. (defun explode (sym)
  21. (map 'list #'(lambda (c)
  22. (intern (make-string 1 :initial-element c)))
  23. (symbol-name sym)))
  24.  
  25. (defun string-symbolist (str)
  26. (explode (intern (string-upcase str))))
  27.  
  28. (defun call (key alist)
  29. (funcall (cdr (assoc key alist))))
  30.  
  31. (defun make-jump-table (code)
  32. (do ((pos 0 (1+ pos))
  33. (c code (cdr c))
  34. (table (make-hash-table))
  35. (stack nil))
  36. ((null c) table)
  37. (case (car c)
  38. (loop-begin (push pos stack))
  39. (loop-end (let ((pop-pos (pop stack)))
  40. (setf (gethash pos table) pop-pos)
  41. (setf (gethash pop-pos table) pos))))))
  42.  
  43. (defun make-brainfuck-closure (code)
  44. (let ((memory (make-array *MEMORY-SIZE* :initial-element 0))
  45. (ptr 0)
  46. (jump-table (make-jump-table code)))
  47. (let* ((code-length (length code))
  48. (program (make-array code-length :initial-contents code))
  49. (prog-ptr 0))
  50. (flet ((jump () (setq prog-ptr (gethash prog-ptr jump-table)) (decf prog-ptr)))
  51. (let ((closure-alist
  52. (list (cons 'inc-pointer #'(lambda () (incf ptr)))
  53. (cons 'dec-pointer #'(lambda () (decf ptr)))
  54. (cons 'inc-value #'(lambda () (incf (aref memory ptr))))
  55. (cons 'dec-value #'(lambda () (decf (aref memory ptr))))
  56. (cons 'putchar #'(lambda () (princ (code-char (aref memory ptr)))))
  57. (cons 'getchar #'(lambda () (setq ptr (char-code (read-char)))))
  58. (cons 'loop-begin
  59. #'(lambda () (when (zerop (aref memory ptr)) (jump))))
  60. (cons 'loop-end
  61. #'(lambda () (unless (zerop (aref memory ptr)) (jump)))))))
  62. (lambda ()
  63. (when (< prog-ptr code-length)
  64. (call (aref program prog-ptr) closure-alist)
  65. (incf prog-ptr))))))))
  66.  
  67. (defun brainfuck (code)
  68. (let ((step (make-brainfuck-closure code)))
  69. (loop while (funcall step))))
  70.  
  71. (defun parse (code)
  72. (mapcar #'(lambda (sym)
  73. (cadr (assoc sym *COMMANDS*)))
  74. code))
  75.  
  76. (defun get-code (file)
  77. (string-symbolist (collect-string (file-to-list file))))
  78.  
  79. (defun main (args)
  80. (unless args (error "第一引数にファイルを指定してください"))
  81. (let ((code (get-code (car args))))
  82. (brainfuck (parse code))))
  83.  
Success #stdin #stdout 0.02s 10624KB
stdin
Standard input is empty
stdout
Standard output is empty