steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Compile brainfuck a bit more stylishly.

db4
John Benediktsson 2009-06-06 20:44:48 -07:00
parent e30a9fc4b1
commit 67a36883fe
1 changed files with 30 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
extra/brainfuck/brainfuck.factor
View File

@ -1,64 +1,64 @@
! Copyright (C) 2009 John Benediktsson ! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license ! See http://factorcode.org/license.txt for BSD license
USING: accessors assocs fry io io.streams.string kernel macros math peg.ebnf sequences strings ; USING: accessors assocs fry io io.streams.string kernel macros math
peg.ebnf quotations sequences strings ;
IN: brainfuck IN: brainfuck
<PRIVATE <PRIVATE
TUPLE: brainfuck ptr mem ops ; TUPLE: brainfuck pointer memory ops ;
: <brainfuck> ( -- brainfuck ) : <brainfuck> ( -- brainfuck )
0 H{ } clone 0 brainfuck boa ; 0 H{ } clone 0 brainfuck boa ;
: ops? ( brainfuck -- brainfuck ) : max-ops? ( brainfuck -- brainfuck )
[ 1 + ] change-ops [ 1 + dup 10000 > [ "Max operations" throw ] when ] change-ops ;
dup ops>> 10000 > [ "Max operations" throw ] when ;
: (get-mem) ( brainfuck -- brainfuck value ) : get-memory ( brainfuck -- brainfuck value )
dup [ ptr>> ] [ mem>> ] bi at 0 or ; dup [ pointer>> ] [ memory>> ] bi at 0 or ;
: (set-mem) ( brainfuck value -- brainfuck ) : set-memory ( brainfuck value -- brainfuck )
over [ ptr>> ] [ mem>> ] bi set-at ; over [ pointer>> ] [ memory>> ] bi set-at ;
: mem++ ( brainfuck -- brainfuck ) : (+) ( brainfuck -- brainfuck )
(get-mem) 1 + 255 bitand (set-mem) ops? ; get-memory 1 + 255 bitand set-memory max-ops? ;
: mem-- ( brainfuck -- brainfuck ) : (-) ( brainfuck -- brainfuck )
(get-mem) 1 - 255 bitand (set-mem) ops? ; get-memory 1 - 255 bitand set-memory max-ops? ;
: mem? ( brainfuck -- brainfuck t/f ) : (?) ( brainfuck -- brainfuck t/f )
ops? (get-mem) 0 = not ; max-ops? get-memory 0 = not ;
: out ( brainfuck -- brainfuck ) : (.) ( brainfuck -- brainfuck )
(get-mem) 1string write ops? ; get-memory 1string write max-ops? ;
: in ( brainfuck -- brainfuck ) : (,) ( brainfuck -- brainfuck )
read1 (set-mem) ops? ; read1 set-memory max-ops? ;
: ptr++ ( brainfuck -- brainfuck ) : (>) ( brainfuck -- brainfuck )
[ 1 + ] change-ptr ops? ; [ 1 + ] change-pointer max-ops? ;
: ptr-- ( brainfuck -- brainfuck ) : (<) ( brainfuck -- brainfuck )
[ 1 - ] change-ptr ops? ; [ 1 - ] change-pointer max-ops? ;
: compose-all ( seq -- quot ) : compose-all ( seq -- quot )
[ ] [ compose ] reduce ; [ ] [ compose ] reduce ;
EBNF: parse-brainfuck EBNF: parse-brainfuck
inc-ptr = ">" => [[ [ ptr++ ] ]] inc-ptr = ">" => [[ [ (>) ] ]]
dec-ptr = "<" => [[ [ ptr-- ] ]] dec-ptr = "<" => [[ [ (<) ] ]]
inc-mem = "+" => [[ [ mem++ ] ]] inc-mem = "+" => [[ [ (+) ] ]]
dec-mem = "-" => [[ [ mem-- ] ]] dec-mem = "-" => [[ [ (-) ] ]]
output = "." => [[ [ out ] ]] output = "." => [[ [ (.) ] ]]
input = "," => [[ [ in ] ]] input = "," => [[ [ (,) ] ]]
space = (" "|"\t"|"\r\n"|"\n") => [[ [ ] ]] space = (" "|"\t"|"\r\n"|"\n") => [[ [ ] ]]
unknown = (.) => [[ "Invalid input" throw ]] unknown = (.) => [[ "Invalid input" throw ]]
ops = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space ops = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space
loop = "[" {loop|ops}* "]" => [[ second compose-all '[ [ mem? ] _ while ] ]] loop = "[" {loop|ops}* "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]]
code = (loop|ops|unknown)* => [[ compose-all ]] code = (loop|ops|unknown)* => [[ compose-all ]]