brainfuck2.rkt

#lang racket

(require srfi/1 srfi/11)

;;;;; Read

(define (read-file file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop ((counter 0) (code '()) (ls '()) (stack '()) (c (read-char)))
        (if (eof-object? c)
            (if (null? ls)
                (values (reverse code) stack)
                (raise 'parenthesis))
            (case c
              ((#\> #\< #\+ #\- #\. #\,) (loop (+ counter 1) (cons c code) ls stack (read-char)))
              ((#\[) (loop (+ counter 1) (cons c code) (cons counter ls) stack (read-char)))
              ((#\]) (if (null? ls)
                         (raise 'parenthesis)
                         (loop (+ counter 1) (cons c code) (cdr ls) 
                               (alist-cons (car ls) counter (alist-cons counter (car ls) stack)) 
                               (read-char))))
              (else (loop counter code ls stack (read-char)))))))))

;;; read-file-test
;(read-file "./helloworld.txt")
;(let-values (((a b) (read-file "./quine.txt")))
;  (values a (length a) b))

(define (parser x phase counter code pointer memory stack)
  (case phase
    ((read-file) (let ((i (read)))
                   (let ((file-name (if (string? i)
                                        i
                                        (symbol->string i))))
                     (let-values (((code stack) (read-file file-name)))
                       (values x phase counter code pointer memory stack)))))
    ((read-char) (values (read-char) phase counter code pointer memory stack))
    ((read) (values (read) phase counter code pointer memory stack))
    (else (values x phase counter code pointer memory stack))))

;;; Read-test
;(parser #f #f 0 #f 0 '((0 . 0)) #f)
;(parser #f 'introduction 0 #f 0 '((0 . 0)) #f)
;(parser #f 'read 0 #f 0 '((0 . 0)) #f)
;(parser #f 'read-file 0 #f 0 '((0 . 0)) #f)
;(parser #f 'read-char 0 #f 0 '((0 . 0)) #f)
;(parser #f 'put-char 0 #f 0 '((0 . 0)) #f)

;;;;; Eval

(define (interp x phase counter code pointer memory stack)
  (case phase
    ((introduction) (values x 'read counter code pointer memory stack))
    ((read) (case x
              ((quit exit bye) (exit))
              ((load open read-file) (values x 'read-file counter code pointer memory stack))
              (else (values x 'read counter code pointer memory stack))))
    ((read-file) (interp x 'execute counter code pointer memory stack))
    ((read-char) (let ((datum (+ (cdr (assv pointer memory)) (char->integer x))))
                   (interp x 'execute counter code pointer (alist-cons pointer datum memory) stack)))
    ((put-char) (interp x 'execute counter code pointer memory stack))
    ((execute) (if (= counter (length code))
                   (values #f 'read 0 #f 0 '((0 . 0)) #f)
                   (case (list-ref code counter)
                     ((#\>) (let ((ptr (+ pointer 1)))
                              (let ((apair (assv ptr memory)))
                                (interp x phase (+ counter 1) code ptr (if apair
                                                                           memory 
                                                                           (alist-cons ptr 0 memory)) stack))))
                     ((#\<) (let ((ptr (- pointer 1)))
                              (if (negative? ptr)
                                  (raise 'under-flow)
                                  (interp x phase (+ counter 1) code ptr memory stack))))
                     ((#\+) (let ((datum (+ (cdr (assv pointer memory)) 1)))
                              (interp x phase (+ counter 1) code pointer (alist-cons pointer datum (alist-delete pointer memory)) stack)))
                     ((#\-) (let ((datum (- (cdr (assv pointer memory)) 1)))
                              (interp x phase(+ counter 1) code pointer (alist-cons pointer datum (alist-delete pointer memory)) stack)))
                     ((#\.) (let ((datum (integer->char (cdr (assv pointer memory)))))
                              (values datum 'put-char (+ counter 1) code pointer memory stack)))
                     ((#\,) (values x 'read-char (+ counter 1) code pointer memory stack))
                     ((#\[) (let ((datum (cdr (assv pointer memory))) (apair (assv counter stack)))
                              (interp x phase (+ (if (zero? datum)
                                                     (cdr (assv counter stack)) 
                                                     counter) 1) code pointer memory stack)))
                     ((#\]) (interp x phase (cdr (assv counter stack)) code pointer memory stack)))))
    ((break) (values x 'exception counter code pointer memory stack))
    ((exception) (values #f 'read 0 #f 0 '((0 . 0)) '()))
    (else (values x 'introduction counter code pointer memory stack))))

;;; Eval-test
;(define code (string->list "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+."))
;(interp #f #f 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #f 'introduction 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp 'exit 'read 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp 'load 'read 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #f 'read-file 0 code 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #f 'execute 0 code 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #\H 'put-char 44 code 1 '((0 . 0) (3 . 45) (2 . 99) (1 . 72)) '((9 . 41) (41 . 9)))
;(define quine (string->list "->++>+++>+>+>+++>>>>>>>>>>>>>>>>>>>>>>+>+>++>+++>++>>+++>+>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>+>+>>+++>>>>+++>>>+++>+>>>>>>>++>+++>+++>+>>+++>+++>+>+++>+>+++>+>++>+++>>>+>+>+>+>++>+++>+>+>>+++>>>>>>>+>+>>>+>+>++>+++>+++>+>>+++>+++>+>+++>+>++>+++>++>>+>+>++>+++>+>+>>+++>>>+++>+>>>++>+++>+++>+>>+++>>>+++>+>+++>+>>+++>>+++>>+[[>>+[>]+>+[<]<-]>>[>]<+<+++[<]<<+]>>>[>]+++>+[+[<++++++++++++++++>-]<++++++++++.<]"))
;(interp #f 'execute 0 quine 0 '((0 . 0))'((367 . 403) (403 . 367) (369 . 389) (389 . 369) (359 . 361) (361 . 359) (321 . 355) (355 . 321) (349 . 351) (351 . 349) (340 . 342) (342 . 340) (322 . 337) (337 . 322) (332 . 334) (334 . 332) (326 . 328) (328 . 326)))

;;;;; Print

(define *messages*
  '((prompt . "brainfuck ==> ")
    (read-char . "enter a character? ==>")
    (read-file . "load? ==> ")
    (introduction . "\nA Brainfuck up interpreter fuckin' impremented with Scheme the Fuck\nCopyTheFuckLeft by Cametan in the fuckin' year 2014\n")
    ))

(define (print x phase counter code pointer memory stack)
  (case phase
    ((introduction read-char read-file) (display (cdr (assq phase *messages*))))
    ((put-char exception) (display x))
    (else (newline) (display (cdr (assq 'prompt *messages*)))))
  (values x phase counter code pointer memory stack))

;;;;; REPL

(define (repl x phase counter code pointer memory stack)
  (with-handlers ((exn:fail:filesystem:errno?
                   (lambda (ext) (repl "the file not found" 'break counter code pointer memory stack)))
                  ((lambda (v) (eq? v 'parenthesis)) 
                   (lambda (v) (repl "number of parenthesis doesn't match" 'break counter code pointer memory stack)))
                  ((lambda (v) (eq? v 'under-flow))
                   (lambda (v) (repl "pointer under flow" 'break counter code pointer memory stack)))
                  )
    (let-values (((x phase counter code pointer memory stack) (parser x phase counter code pointer memory stack)))
      (let-values (((x phase counter code pointer memory stack) (interp x phase counter code pointer memory stack)))
        (let-values (((x phase counter code pointer memory stack) (print x phase counter code pointer memory stack)))
          (repl x phase counter code pointer memory stack))))))

(repl #f #f 0 #f 0 '((0 . 0)) #f) ; 初期値はこのようにして与える