benchmarks/brainfuck2/bf.rkt at 22e854cc17d5552019a10c9c686deeb232899759 · kostya/benchmarks · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
#lang racket
(require racket/file racket/list racket/match racket/cmdline racket/os
         (rename-in racket/unsafe/ops
                    [unsafe-vector-ref vector-ref]
                    [unsafe-vector-set! vector-set!]
                    [unsafe-fx+ +]))

(define-syntax-rule (define-match-expander* k r) (define-match-expander k r r))
(define-match-expander* op (syntax-rules () [(_ op val) (cons op val)]))
(define-match-expander* tape (syntax-rules () [(_ data pos) (mcons data pos)]))

;;; Vector and tape ops.

(define (vector-grow-if-needed vec len)
  (define old-len (vector-length vec))
  (cond [(< len old-len) vec]
        [else
         (let loop ([new-len (* 2 old-len)])
           (cond [(>= len new-len) (loop (* 2 new-len))]
                 [else (define new-vec (make-vector new-len))
                       (vector-copy! new-vec 0 vec)
                       new-vec]))]))

(define (tape-get t)
  (match-let ([(tape data pos) t])
    (vector-ref data pos)))

(define (tape-move! t n)
  (match-let ([(tape data pos) t])
    (let ([new-pos (+ n pos)])
      (set-mcar! t (vector-grow-if-needed data new-pos))
      (set-mcdr! t new-pos))))

(define (tape-inc! t n)
  (match-let ([(tape data pos) t])
    (vector-set! data pos (+ n (vector-ref data pos)))))

;;; Parser.

(define (parse-helper lst acc)
  (if (empty? lst)
      (reverse acc)
      (let ([rst (rest lst)])
        (match (first lst)
          [#\+ (parse-helper rst (cons (op 'inc 1) acc))]
          [#\- (parse-helper rst (cons (op 'inc -1) acc))]
          [#\> (parse-helper rst (cons (op 'move 1) acc))]
          [#\< (parse-helper rst (cons (op 'move -1) acc))]
          [#\. (parse-helper rst (cons 'print acc))]
          [#\[ (let ([subparsed (parse-helper rst empty)])
                 (parse-helper (first subparsed)
                               (cons (op 'loop (rest subparsed)) acc)))]
          [#\] (cons rst (reverse acc))]
          [_ (parse-helper rst acc)]))))

(define (parse bf-code) (parse-helper (string->list bf-code) empty))

;;; Interpreter.

(define (run parsed t)
  (define step-op!
    (match-lambda
      [(op 'inc x) (tape-inc! t x)]
      [(op 'move x) (tape-move! t x)]
      ['print (display (integer->char (tape-get t)))
              (flush-output)]
      [(op 'loop body) (let loop ()
                         (when (> (tape-get t) 0)
                           (step-ops! body)
                           (loop)))]))
  (define step-ops!
    (match-lambda
      [(cons op ops) (step-op! op) (step-ops! ops)]
      [_ (void)]))
  (step-ops! parsed))

(define (notify msg)
  (with-handlers ([exn:fail:network? (lambda (_) (void))])
    (let-values ([(in out) (tcp-connect "localhost" 9001)])
      (display msg out)
        (close-output-port out))))

(define (read-c path)
  (parameterize ([current-locale "C"])
    (file->string path)))

(define text null)
(set! text (read-c (command-line #:args (filename) filename)))

(notify (format "Racket\t~s" (getpid)))

(run (parse text) (tape (vector 0) 0))

(notify "stop")