diff --git a/bf/lang/reader.rkt b/bf/lang/reader.rkt new file mode 100644 index 0000000..969a404 --- /dev/null +++ b/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)])) + diff --git a/bf/language.rkt b/bf/language.rkt new file mode 100644 index 0000000..d49aaf4 --- /dev/null +++ b/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 ...)))])) \ No newline at end of file diff --git a/bf/parser.rkt b/bf/parser.rkt new file mode 100644 index 0000000..6051338 --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/bf/semantics.rkt b/bf/semantics.rkt new file mode 100644 index 0000000..e5a535f --- /dev/null +++ b/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))))) + diff --git a/examples/hello-bf.rkt b/examples/hello-bf.rkt new file mode 100644 index 0000000..24b4b5f --- /dev/null +++ b/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' diff --git a/js-assembler/runtime-src/baselib-check.js b/js-assembler/runtime-src/baselib-check.js index 1182e6c..d2e4df0 100644 --- a/js-assembler/runtime-src/baselib-check.js +++ b/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; diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 68b1d2e..255151b 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/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) { diff --git a/lang/kernel.rkt b/lang/kernel.rkt index 851c35d..883a5d2 100644 --- a/lang/kernel.rkt +++ b/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