suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

unholy. Brainf*ck in Whalesong

Browse Source
This commit is contained in:
Danny Yoo 2011-07-21 18:25:55 -04:00
parent 041681c5d0
commit 26cd925d37
8 changed files with 377 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
bf/lang/reader.rkt Normal file
View File

@ -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)]))

103
bf/language.rkt Normal file
View File

@ -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 ...)))]))

114
bf/parser.rkt Normal file
View File

@ -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)))

81
bf/semantics.rkt Normal file
View File

@ -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)))))

23
examples/hello-bf.rkt Normal file
View File

@ -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'

5
js-assembler/runtime-src/baselib-check.js
View File

@ -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;

15
js-assembler/runtime-src/runtime.js
View File

@ -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) {

8
lang/kernel.rkt
View File

@ -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