unholy. Brainf*ck in Whalesong

bf/lang/reader.rkt

@@ -0,0 +1,30 @@
+#lang s-exp syntax/module-reader
+(planet dyoo/whalesong/bf/language)   ;; switched from (planet dyoo/bf/language)
+#:read my-read
+#:read-syntax my-read-syntax
+#:info my-get-info
+(require "../parser.rkt")
+
+(define (my-read in)
+  (syntax->datum (my-read-syntax #f in)))
+
+(define (my-read-syntax src in)
+  (parse-expr src in))
+
+
+
+;; Extension: we'd like to cooperate with DrRacket and tell
+;; it to use the default, textual lexer and color scheme when
+;; editing bf programs.
+;;
+;; See: http://docs.racket-lang.org/guide/language-get-info.html
+;; for more details, as well as the documentation in
+;; syntax/module-reader.
+(define (my-get-info key default default-filter)
+  (case key
+    [(color-lexer)
+     (dynamic-require 'syntax-color/default-lexer
+                      'default-lexer)]
+    [else
+     (default-filter key default)]))
+

bf/language.rkt

@@ -0,0 +1,103 @@
+#lang planet dyoo/whalesong
+
+(require "semantics.rkt"
+         (for-syntax racket/base))
+
+(provide greater-than
+         less-than
+         plus
+         minus
+         period
+         comma
+         brackets
+         (rename-out [my-module-begin #%module-begin]))
+
+
+
+
+;; Every module in this language will make sure that it
+;; uses a fresh state.  We create one, and then within
+;; the lexical context of a my-module-begin, all the
+;; other forms will refer to current-state.
+(define-syntax (my-module-begin stx)
+  (syntax-case stx ()
+    [(_ body ...)
+     (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                   [current-ptr (datum->syntax stx 'current-ptr)])
+       (syntax/loc stx
+         (#%plain-module-begin
+          (define-values (current-data current-ptr) (new-state))
+          (define (run)
+            (begin body ... (void)))
+          (run))))]))
+
+
+;; In order to produce good runtime error messages
+;; for greater-than and less-than, we latch onto 
+;; the syntax object for dear life, since it has
+;; information about where it came from in the
+;; source syntax.
+;;
+;; The #'#,stx nonsense below allows us to pass the
+;; syntax object.  The semantics can then raise an
+;; appropriate syntactic error with raise-syntax-error
+;; if it sees anything bad happen at runtime.
+(define-syntax (greater-than stx)
+  (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                [current-ptr (datum->syntax stx 'current-ptr)])
+    (syntax-case stx ()
+      [(_)
+       (quasisyntax/loc stx
+         (increment-ptr current-data current-ptr
+                        (srcloc '#,(syntax-source stx)
+                                '#,(syntax-line stx)
+                                '#,(syntax-column stx)
+                                '#,(syntax-position stx)
+                                '#,(syntax-span stx))))])))
+
+
+(define-syntax (less-than stx)
+  (syntax-case stx ()
+    [(_)
+     (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                   [current-ptr (datum->syntax stx 'current-ptr)])
+       (quasisyntax/loc stx
+         (decrement-ptr current-data current-ptr
+                        (srcloc '#,(syntax-source stx)
+                                '#,(syntax-line stx)
+                                '#,(syntax-column stx)
+                                '#,(syntax-position stx)
+                                '#,(syntax-span stx)))))]))
+
+
+(define-syntax (plus stx)
+  (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                [current-ptr (datum->syntax stx 'current-ptr)])
+    (syntax/loc stx
+      (increment-byte current-data current-ptr))))
+
+(define-syntax (minus stx)
+  (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                [current-ptr (datum->syntax stx 'current-ptr)])
+    (syntax/loc stx
+      (decrement-byte current-data current-ptr))))
+
+(define-syntax (period stx)
+  (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                [current-ptr (datum->syntax stx 'current-ptr)])
+    (syntax/loc stx 
+      (write-byte-to-stdout current-data current-ptr))))
+
+(define-syntax (comma stx)
+  (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                [current-ptr (datum->syntax stx 'current-ptr)])
+    (syntax/loc stx
+      (read-byte-from-stdin current-data current-ptr))))
+
+(define-syntax (brackets stx)
+  (syntax-case stx ()
+    [(_ body ...)
+     (with-syntax ([current-data (datum->syntax stx 'current-data)]
+                   [current-ptr (datum->syntax stx 'current-ptr)])
+       (syntax/loc stx
+         (loop current-data current-ptr body ...)))]))

bf/parser.rkt

@@ -0,0 +1,114 @@
+#lang racket
+(require rackunit)
+
+(provide parse-expr)
+
+;; While loops...
+(define-syntax-rule (while test body ...)
+  (let loop ()
+    (when test
+      body ...
+      (loop))))
+
+
+;; ignorable-next-char?: input-port -> boolean
+;; Produces true if the next character is something we should ignore.
+(define (ignorable-next-char? in)
+  (let ([next-ch (peek-char in)])
+    (cond
+      [(eof-object? next-ch)
+       #f]
+      [else
+       (not (member next-ch '(#\< #\> #\+ #\- #\, #\. #\[ #\])))])))
+
+
+;; parse-expr: any input-port -> (U syntax eof)
+;; Either produces a syntax object or the eof object.
+(define (parse-expr source-name in)
+  (while (ignorable-next-char? in) (read-char in))
+  (let*-values ([(line column position) (port-next-location in)]
+                [(next-char) (read-char in)])
+    
+    ;; We'll use this function to generate the syntax objects by
+    ;; default.
+    ;; The only category this doesn't cover are brackets.
+    (define (default-make-syntax type)
+      (datum->syntax #f 
+                     (list type)
+                     (list source-name line column position 1)))
+    (cond
+      [(eof-object? next-char) eof]
+      [else
+       (case next-char
+         [(#\<) (default-make-syntax 'less-than)]
+         [(#\>) (default-make-syntax 'greater-than)]
+         [(#\+) (default-make-syntax 'plus)]
+         [(#\-) (default-make-syntax 'minus)]
+         [(#\,) (default-make-syntax 'comma)]
+         [(#\.) (default-make-syntax 'period)]
+         [(#\[)
+          ;; The slightly messy case is bracket.  We keep reading
+          ;; a list of exprs, and then construct a wrapping bracket
+          ;; around the whole thing.
+          (let*-values ([(elements) (parse-exprs source-name in)]
+                        [(following-line following-column 
+                                         following-position) 
+                         (port-next-location in)])
+            (datum->syntax #f 
+                           `(brackets ,@elements)
+                           (list source-name
+                                 line 
+                                 column 
+                                 position 
+                                 (- following-position
+                                    position))))]
+         [(#\])
+          eof])])))
+
+
+;; parse-exprs: input-port -> (listof syntax)
+;; Parse a list of expressions.
+(define (parse-exprs source-name in)
+  (let ([next-expr (parse-expr source-name in)])
+    (cond
+      [(eof-object? next-expr)
+       empty]
+      [else
+       (cons next-expr (parse-exprs source-name in))])))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; simple tests
+(check-equal? eof (parse-expr 'test (open-input-string "")))
+(check-equal? '(greater-than) 
+              (syntax->datum (parse-expr 'test (open-input-string ">"))))
+(check-equal? '(less-than) 
+              (syntax->datum (parse-expr 'test (open-input-string "<"))))
+(check-equal? '(plus) 
+              (syntax->datum (parse-expr 'test (open-input-string "+"))))
+(check-equal? '(minus)
+              (syntax->datum (parse-expr 'test (open-input-string "-"))))
+(check-equal? '(comma)
+              (syntax->datum (parse-expr 'test (open-input-string ","))))
+(check-equal? '(period)
+              (syntax->datum (parse-expr 'test (open-input-string "."))))
+
+
+;; bracket tests
+(check-equal? '(brackets) 
+              (syntax->datum (parse-expr 'test (open-input-string "[]"))))
+(check-equal? '(brackets (brackets))
+              (syntax->datum (parse-expr 'test (open-input-string "[[]]"))))
+
+
+;; Parsing the "cat" function
+(let ([port (open-input-string ",[.,]")])
+  (check-equal? '(comma) 
+                (syntax->datum (parse-expr 'test port)))
+  (check-equal? '(brackets (period) (comma))
+                (syntax->datum (parse-expr 'test port)))
+  (check-equal? eof
+                (parse-expr 'test port)))

bf/semantics.rkt

@@ -0,0 +1,81 @@
+#lang planet dyoo/whalesong
+
+;; This is a second semantics for the language that tries to go for speed,
+;; at the expense of making things a little more complicated.
+;;
+;; It uses features in: http://docs.racket-lang.org/reference/unsafe.html
+;; to reduce the number of runtime checks.
+;;
+;; We also manage the state as two separate values.
+;;
+;; Tape out-of-bounds errors at runtime should be properly reported with
+;; source location.
+
+(require (for-syntax racket/base)) 
+
+
+(provide (all-defined-out))
+
+
+
+(define-syntax MAX-DATA-SIZE
+  (lambda (stx) #'30000))
+
+
+
+;; Creates a new state, with a byte array of 30000 zeros, and
+;; the pointer at index 0.
+(define-syntax-rule (new-state) 
+  (values (make-vector MAX-DATA-SIZE 0)
+          0))
+
+
+;; increment the data pointer
+(define-syntax-rule (increment-ptr data ptr loc)
+  (begin
+    (set! ptr (+ ptr 1))))
+
+
+;; decrement the data pointer
+(define-syntax-rule (decrement-ptr data ptr loc)
+  (set! ptr (- ptr 1)))
+
+
+;; increment the byte at the data pointer
+(define-syntax-rule (increment-byte data ptr)
+  (vector-set! data ptr
+                     (modulo
+                      (+ (vector-ref data ptr)
+                                  1)
+                      256)))
+
+;; decrement the byte at the data pointer
+(define-syntax-rule (decrement-byte data ptr)
+  (vector-set! data ptr
+                     (modulo
+                      (- (vector-ref data ptr)
+                                  1)
+                      256)))
+
+;; print the byte at the data pointer
+(define-syntax-rule (write-byte-to-stdout data ptr)
+  (write-byte (vector-ref data ptr)))
+
+
+;; ;; read a byte from stdin into the data pointer
+;; (define-syntax-rule (read-byte-from-stdin data ptr)
+;;   (vector-set! data ptr (let ([v (read-byte (current-input-port))])
+;;                                  (if (eof-object? v)
+;;                                      0
+;;                                      v))))
+
+;; Loops
+(define-syntax-rule (loop data ptr body ...)
+  (unless (= (vector-ref data ptr)
+                      0)
+    (let loop ()
+      body ...
+      (unless (= (vector-ref data ptr)
+                          0)
+        (loop)))))
+

examples/hello-bf.rkt

@@ -0,0 +1,23 @@
+#lang planet dyoo/whalesong/bf
+
++++++ +++++             initialize counter (cell #0) to 10
+[                       use loop to set the next four cells to 70/100/30/10
+    > +++++ ++              add  7 to cell #1
+    > +++++ +++++           add 10 to cell #2 
+    > +++                   add  3 to cell #3
+    > +                     add  1 to cell #4
+    <<<< -                  decrement counter (cell #0)
+]                   
+> ++ .                  print 'H'
+> + .                   print 'e'
++++++ ++ .              print 'l'
+.                       print 'l'
++++ .                   print 'o'
+> ++ .                  print ' '
+<< +++++ +++++ +++++ .  print 'W'
+> .                     print 'o'
++++ .                   print 'r'
+----- - .               print 'l'
+----- --- .             print 'd'
+> + .                   print '!'
+> .                     print '\n'

js-assembler/runtime-src/baselib-check.js

@@ -150,6 +150,10 @@
         plt.baselib.numbers.isNatural,
         'natural');
 
+    var checkByte = makeCheckArgumentType(
+        function(x) { return (typeof(x) === 'number' && 0 <= x && x < 256) },
+        'byte');
+
     var checkNaturalInRange = makeCheckParameterizedArgumentType(
         function(x, a, b) {
             if (! plt.baselib.numbers.isNatural(x)) { return false; }
@@ -227,6 +231,7 @@
     exports.checkNonNegativeReal = checkNonNegativeReal;
     exports.checkNatural = checkNatural;
     exports.checkNaturalInRange = checkNaturalInRange;
+    exports.checkByte = checkByte;
     exports.checkInteger = checkInteger;
     exports.checkRational = checkRational;
     exports.checkPair = checkPair;

js-assembler/runtime-src/runtime.js

@@ -110,6 +110,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
     var checkOutputPort = plt.baselib.check.checkOutputPort;
     var checkString = plt.baselib.check.checkString;
     var checkSymbol = plt.baselib.check.checkSymbol;
+    var checkByte = plt.baselib.check.checkByte;
     var checkProcedure = plt.baselib.check.checkProcedure;
     var checkNumber = plt.baselib.check.checkNumber;
     var checkReal = plt.baselib.check.checkReal;
@@ -546,6 +547,20 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
             return VOID;
         });
 
+
+    installPrimitiveProcedure(
+        'write-byte', makeList(1, 2),
+        function(MACHINE) {
+	    var firstArg = checkByte(MACHINE, 'write-byte', 0);
+	    var outputPort = MACHINE.params.currentOutputPort;
+	    if (MACHINE.argcount === 2) {
+	        outputPort = checkOutputPort(MACHINE, 'display', 1);
+	    }
+	    outputPort.writeDomNode(MACHINE, toDomNode(String.fromCharCode(firstArg), 'display'));
+            return VOID;
+        });
+
+
     installPrimitiveProcedure(
         'newline', makeList(0, 1),
         function(MACHINE) {

lang/kernel.rkt

@@ -60,6 +60,7 @@
          pi
          e
          null
+         #%plain-module-begin
 	 #%module-begin
 	 #%datum
 	 #%app
@@ -106,6 +107,7 @@
 	 except-out
 	 rename-out
 	 struct-out
+         define-syntax-rule
 	 define-syntax
 	 define-syntaxes
 
@@ -135,7 +137,8 @@
          list
          null?
          not
-         eq?)
+         eq?
+         values)
 
 
 (define (-identity x) x)
@@ -153,6 +156,7 @@
  current-output-port
  current-print 
  write
+ write-byte
  display
  newline
  displayln
@@ -177,7 +181,7 @@
 ;;  arity-at-least?
 ;;  arity-at-least-value
 ;;  apply
-;;  values
+
 ;;  call-with-values
 ;;  compose
 ;;  current-inexact-milliseconds