Merge branch 'master' of git://factorcode.org/git/factor
commit
f0480b7cf4
|
@ -4,8 +4,8 @@ USING: math kernel layouts system ;
|
||||||
IN: compiler.constants
|
IN: compiler.constants
|
||||||
|
|
||||||
! These constants must match vm/memory.h
|
! These constants must match vm/memory.h
|
||||||
: card-bits 6 ;
|
: card-bits 8 ;
|
||||||
: deck-bits 12 ;
|
: deck-bits 18 ;
|
||||||
: card-mark HEX: 40 HEX: 80 bitor ;
|
: card-mark HEX: 40 HEX: 80 bitor ;
|
||||||
|
|
||||||
! These constants must match vm/layouts.h
|
! These constants must match vm/layouts.h
|
||||||
|
|
|
@ -18,13 +18,13 @@ IN: cpu.ppc.intrinsics
|
||||||
"obj" get operand-tag - ;
|
"obj" get operand-tag - ;
|
||||||
|
|
||||||
: %slot-literal-any-tag
|
: %slot-literal-any-tag
|
||||||
"obj" operand "scratch" operand %untag
|
"obj" operand "scratch1" operand %untag
|
||||||
"val" operand "scratch" operand "n" get cells ;
|
"val" operand "scratch1" operand "n" get cells ;
|
||||||
|
|
||||||
: %slot-any
|
: %slot-any
|
||||||
"obj" operand "scratch" operand %untag
|
"obj" operand "scratch1" operand %untag
|
||||||
"offset" operand "n" operand 1 SRAWI
|
"offset" operand "n" operand 1 SRAWI
|
||||||
"scratch" operand "val" operand "offset" operand ;
|
"scratch1" operand "val" operand "offset" operand ;
|
||||||
|
|
||||||
\ slot {
|
\ slot {
|
||||||
! Slot number is literal and the tag is known
|
! Slot number is literal and the tag is known
|
||||||
|
@ -39,7 +39,7 @@ IN: cpu.ppc.intrinsics
|
||||||
{
|
{
|
||||||
[ %slot-literal-any-tag LWZ ] H{
|
[ %slot-literal-any-tag LWZ ] H{
|
||||||
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
|
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
|
||||||
{ +scratch+ { { f "scratch" } { f "val" } } }
|
{ +scratch+ { { f "scratch1" } { f "val" } } }
|
||||||
{ +output+ { "val" } }
|
{ +output+ { "val" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -47,7 +47,7 @@ IN: cpu.ppc.intrinsics
|
||||||
{
|
{
|
||||||
[ %slot-any LWZX ] H{
|
[ %slot-any LWZX ] H{
|
||||||
{ +input+ { { f "obj" } { f "n" } } }
|
{ +input+ { { f "obj" } { f "n" } } }
|
||||||
{ +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
|
{ +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
|
||||||
{ +output+ { "val" } }
|
{ +output+ { "val" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -61,17 +61,17 @@ IN: cpu.ppc.intrinsics
|
||||||
|
|
||||||
: %write-barrier ( -- )
|
: %write-barrier ( -- )
|
||||||
"val" get operand-immediate? "obj" get fresh-object? or [
|
"val" get operand-immediate? "obj" get fresh-object? or [
|
||||||
"scratch1" operand card-mark LI
|
card-mark "scratch1" operand LI
|
||||||
|
|
||||||
! Mark the card
|
! Mark the card
|
||||||
"val" operand load-cards-offset
|
"val" operand load-cards-offset
|
||||||
"obj" operand "scratch2" operand card-bits SRWI
|
"obj" operand "scratch2" operand card-bits SRWI
|
||||||
"scratch1" operand "scratch2" operand "val" operand STBX
|
"scratch2" operand "scratch1" operand "val" operand STBX
|
||||||
|
|
||||||
! Mark the card deck
|
! Mark the card deck
|
||||||
"val" operand load-decks-offset
|
"val" operand load-decks-offset
|
||||||
"obj" operand "scratch2" operand deck-bits SRWI
|
"obj" operand "scratch2" operand deck-bits SRWI
|
||||||
"scratch1" operand "scratch2" operand "val" operand STBX
|
"scratch2" operand "scratch1" operand "val" operand STBX
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
\ set-slot {
|
\ set-slot {
|
||||||
|
@ -87,7 +87,7 @@ IN: cpu.ppc.intrinsics
|
||||||
{
|
{
|
||||||
[ %slot-literal-any-tag STW %write-barrier ] H{
|
[ %slot-literal-any-tag STW %write-barrier ] H{
|
||||||
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
|
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
|
||||||
{ +scratch+ { { f "scratch" } } }
|
{ +scratch+ { { f "scratch1" } { f "scratch2" } } }
|
||||||
{ +clobber+ { "val" } }
|
{ +clobber+ { "val" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -95,7 +95,7 @@ IN: cpu.ppc.intrinsics
|
||||||
{
|
{
|
||||||
[ %slot-any STWX %write-barrier ] H{
|
[ %slot-any STWX %write-barrier ] H{
|
||||||
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
|
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
|
||||||
{ +scratch+ { { f "scratch" } { f "offset" } } }
|
{ +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
|
||||||
{ +clobber+ { "val" } }
|
{ +clobber+ { "val" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -16,7 +16,7 @@ IN: builder.report
|
||||||
"git id: " write "git-id" eval-file print nl
|
"git id: " write "git-id" eval-file print nl
|
||||||
|
|
||||||
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
|
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
|
||||||
status-boot get f = [ "boot-log" cat "Boot error" throw ] when
|
status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when
|
||||||
status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
|
status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
|
||||||
|
|
||||||
"Boot time: " write "boot-time" eval-file milli-seconds>time print
|
"Boot time: " write "boot-time" eval-file milli-seconds>time print
|
||||||
|
|
|
@ -1,45 +1,47 @@
|
||||||
USING: kernel sequences arrays math.intervals accessors
|
USING: kernel sequences arrays accessors tuple-arrays
|
||||||
math.order sorting math assocs locals namespaces ;
|
math.order sorting math assocs locals namespaces ;
|
||||||
IN: interval-maps
|
IN: interval-maps
|
||||||
|
|
||||||
TUPLE: interval-map array ;
|
TUPLE: interval-map array ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
TUPLE: interval-node interval value ;
|
TUPLE: interval-node from to value ;
|
||||||
|
|
||||||
: fixup-value ( value ? -- value/f ? )
|
: fixup-value ( value ? -- value/f ? )
|
||||||
[ drop f f ] unless* ;
|
[ drop f f ] unless* ;
|
||||||
|
|
||||||
: find-interval ( key interval-map -- i )
|
: find-interval ( key interval-map -- i )
|
||||||
[ interval>> from>> first <=> ] binsearch ;
|
[ from>> <=> ] binsearch ;
|
||||||
|
|
||||||
GENERIC: >interval ( object -- interval )
|
: interval-contains? ( object interval-node -- ? )
|
||||||
M: number >interval [a,a] ;
|
[ from>> ] [ to>> ] bi between? ;
|
||||||
M: sequence >interval first2 [a,b] ;
|
|
||||||
M: interval >interval ;
|
|
||||||
|
|
||||||
: all-intervals ( sequence -- intervals )
|
: all-intervals ( sequence -- intervals )
|
||||||
[ >r >interval r> ] assoc-map ;
|
[ >r dup number? [ dup 2array ] when r> ] assoc-map
|
||||||
|
{ } assoc-like ;
|
||||||
|
|
||||||
|
: disjoint? ( node1 node2 -- ? )
|
||||||
|
[ to>> ] [ from>> ] bi* < ;
|
||||||
|
|
||||||
: ensure-disjoint ( intervals -- intervals )
|
: ensure-disjoint ( intervals -- intervals )
|
||||||
dup keys [ interval-intersect not ] monotonic?
|
dup [ disjoint? ] monotonic?
|
||||||
[ "Intervals are not disjoint" throw ] unless ;
|
[ "Intervals are not disjoint" throw ] unless ;
|
||||||
|
|
||||||
|
: >intervals ( specification -- intervals )
|
||||||
|
[ >r first2 r> interval-node boa ] { } assoc>map ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: interval-at* ( key map -- value ? )
|
: interval-at* ( key map -- value ? )
|
||||||
array>> [ find-interval ] 2keep swapd nth
|
array>> [ find-interval ] 2keep swapd nth
|
||||||
[ nip value>> ] [ interval>> interval-contains? ] 2bi
|
[ nip value>> ] [ interval-contains? ] 2bi
|
||||||
fixup-value ;
|
fixup-value ;
|
||||||
|
|
||||||
: interval-at ( key map -- value ) interval-at* drop ;
|
: interval-at ( key map -- value ) interval-at* drop ;
|
||||||
: interval-key? ( key map -- ? ) interval-at* nip ;
|
: interval-key? ( key map -- ? ) interval-at* nip ;
|
||||||
|
|
||||||
: <interval-map> ( specification -- map )
|
: <interval-map> ( specification -- map )
|
||||||
all-intervals { } assoc-like
|
all-intervals [ [ first second ] compare ] sort
|
||||||
[ [ first to>> ] compare ] sort ensure-disjoint
|
>intervals ensure-disjoint >tuple-array
|
||||||
[ interval-node boa ] { } assoc>map
|
|
||||||
interval-map boa ;
|
interval-map boa ;
|
||||||
|
|
||||||
:: coalesce ( alist -- specification )
|
:: coalesce ( alist -- specification )
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2008 Daniel Ehrenberg
|
! Copyright (C) 2008 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel strings unicode.syntax.backend io.files assocs
|
USING: kernel strings values io.files assocs
|
||||||
splitting sequences io namespaces sets
|
splitting sequences io namespaces sets io.encodings.8-bit
|
||||||
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ;
|
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
|
||||||
IN: io.encodings.iana
|
IN: io.encodings.iana
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007 Alex Chapman
|
! Copyright (C) 2007 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types colors jamshred.game jamshred.oint
|
USING: accessors alien.c-types colors jamshred.game jamshred.oint
|
||||||
jamshred.player jamshred.tunnel kernel math math.vectors opengl
|
jamshred.player jamshred.tunnel kernel math math.vectors opengl
|
||||||
opengl.gl opengl.glu sequences ;
|
opengl.gl opengl.glu sequences ;
|
||||||
IN: jamshred.gl
|
IN: jamshred.gl
|
||||||
|
@ -37,10 +37,6 @@ IN: jamshred.gl
|
||||||
: draw-tunnel ( player -- )
|
: draw-tunnel ( player -- )
|
||||||
segments-to-render draw-segments ;
|
segments-to-render draw-segments ;
|
||||||
|
|
||||||
! : draw-tunnel ( player tunnel -- )
|
|
||||||
! tuck swap player-nearest-segment segment-number dup n-segments-behind -
|
|
||||||
! swap n-segments-ahead + rot sub-tunnel draw-segments ;
|
|
||||||
|
|
||||||
: init-graphics ( width height -- )
|
: init-graphics ( width height -- )
|
||||||
GL_DEPTH_TEST glEnable
|
GL_DEPTH_TEST glEnable
|
||||||
GL_SCISSOR_TEST glDisable
|
GL_SCISSOR_TEST glDisable
|
||||||
|
@ -63,9 +59,9 @@ IN: jamshred.gl
|
||||||
GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
|
GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
|
||||||
|
|
||||||
: player-view ( player -- )
|
: player-view ( player -- )
|
||||||
[ oint-location first3 ] keep
|
[ location>> first3 ]
|
||||||
[ dup oint-location swap oint-forward v+ first3 ] keep
|
[ [ location>> ] [ forward>> ] bi v+ first3 ]
|
||||||
oint-up first3 gluLookAt ;
|
[ up>> first3 ] tri gluLookAt ;
|
||||||
|
|
||||||
: draw-jamshred ( jamshred width height -- )
|
: draw-jamshred ( jamshred width height -- )
|
||||||
init-graphics jamshred-player dup player-view draw-tunnel ;
|
init-graphics jamshred-player dup player-view draw-tunnel ;
|
||||||
|
|
|
@ -127,7 +127,9 @@ C: <segment> segment
|
||||||
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
|
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
|
||||||
|
|
||||||
: collision-vector ( oint segment -- v )
|
: collision-vector ( oint segment -- v )
|
||||||
[ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri
|
[ sideways-heading ] [ sideways-relative-location ]
|
||||||
|
[ radius>> 0.1 - ] ! bounce before we hit so that we can't see through the wall (hack?)
|
||||||
|
2tri
|
||||||
swap [ collision-coefficient ] dip forward>> n*v ;
|
swap [ collision-coefficient ] dip forward>> n*v ;
|
||||||
|
|
||||||
: distance-to-collision ( oint segment -- distance )
|
: distance-to-collision ( oint segment -- distance )
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: lcs
|
||||||
0 1 ? + >r [ 1+ ] bi@ r> min min ;
|
0 1 ? + >r [ 1+ ] bi@ r> min min ;
|
||||||
|
|
||||||
: lcs-step ( insert delete change same? -- next )
|
: lcs-step ( insert delete change same? -- next )
|
||||||
1 -9999 ? + max max ; ! Replace -9999 with -inf when added
|
1 -1./0. ? + max max ; ! -1./0. is -inf (float)
|
||||||
|
|
||||||
:: loop-step ( i j matrix old new step -- )
|
:: loop-step ( i j matrix old new step -- )
|
||||||
i j 1+ matrix nth nth ! insertion
|
i j 1+ matrix nth nth ! insertion
|
||||||
|
@ -25,10 +25,9 @@ IN: lcs
|
||||||
|
|
||||||
:: run-lcs ( old new init step -- matrix )
|
:: run-lcs ( old new init step -- matrix )
|
||||||
[let | matrix [ old length 1+ new length 1+ init call ] |
|
[let | matrix [ old length 1+ new length 1+ init call ] |
|
||||||
old length [0,b) [| i |
|
old length [| i |
|
||||||
new length [0,b)
|
new length
|
||||||
[| j | i j matrix old new step loop-step ]
|
[| j | i j matrix old new step loop-step ] each
|
||||||
each
|
|
||||||
] each matrix ] ; inline
|
] each matrix ] ; inline
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
James Cash
|
|
@ -0,0 +1,21 @@
|
||||||
|
! Copyright (C) 2008 James Cash
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: lisp lisp.parser tools.test sequences math kernel ;
|
||||||
|
|
||||||
|
IN: lisp.test
|
||||||
|
|
||||||
|
{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
|
||||||
|
"(foo 1 2 \"aoeu\")" lisp-string>factor
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
init-env
|
||||||
|
|
||||||
|
"+" [ first2 + ] lisp-define
|
||||||
|
|
||||||
|
{ [ first2 + ] } [
|
||||||
|
"+" lisp-get
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ 3 } [
|
||||||
|
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
|
||||||
|
] unit-test
|
|
@ -0,0 +1,88 @@
|
||||||
|
! Copyright (C) 2008 James Cash
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel peg sequences arrays strings combinators.lib
|
||||||
|
namespaces combinators math bake locals locals.private accessors
|
||||||
|
vectors syntax lisp.parser assocs parser sequences.lib ;
|
||||||
|
IN: lisp
|
||||||
|
|
||||||
|
DEFER: convert-form
|
||||||
|
DEFER: funcall
|
||||||
|
|
||||||
|
! Functions to convert s-exps to quotations
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
: convert-body ( s-exp -- quot )
|
||||||
|
[ convert-form ] map [ ] [ compose ] reduce ; inline
|
||||||
|
|
||||||
|
: convert-if ( s-exp -- quot )
|
||||||
|
rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
|
||||||
|
|
||||||
|
: convert-begin ( s-exp -- quot )
|
||||||
|
rest convert-form ;
|
||||||
|
|
||||||
|
: convert-cond ( s-exp -- quot )
|
||||||
|
rest [ [ convert-form map ] map ] [ % cond ] bake ;
|
||||||
|
|
||||||
|
: convert-general-form ( s-exp -- quot )
|
||||||
|
unclip convert-form swap convert-body [ , % funcall ] bake ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
: localize-body ( vars body -- newbody )
|
||||||
|
[ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ]
|
||||||
|
[ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if
|
||||||
|
] with map ;
|
||||||
|
|
||||||
|
: localize-lambda ( body vars -- newbody newvars )
|
||||||
|
dup make-locals dup push-locals [ swap localize-body <s-exp> convert-form ] dipd
|
||||||
|
pop-locals swap ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: split-lambda ( s-exp -- body vars )
|
||||||
|
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
|
||||||
|
|
||||||
|
: rest-lambda-vars ( seq -- n newseq )
|
||||||
|
"&rest" swap [ remove ] [ index ] 2bi ;
|
||||||
|
|
||||||
|
: convert-lambda ( s-exp -- quot )
|
||||||
|
split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if
|
||||||
|
[ localize-lambda <lambda> ] dip
|
||||||
|
[ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ;
|
||||||
|
|
||||||
|
: convert-quoted ( s-exp -- quot )
|
||||||
|
second [ , ] bake ;
|
||||||
|
|
||||||
|
: convert-list-form ( s-exp -- quot )
|
||||||
|
dup first dup lisp-symbol?
|
||||||
|
[ name>>
|
||||||
|
{ { "lambda" [ convert-lambda ] }
|
||||||
|
{ "quote" [ convert-quoted ] }
|
||||||
|
{ "if" [ convert-if ] }
|
||||||
|
{ "begin" [ convert-begin ] }
|
||||||
|
{ "cond" [ convert-cond ] }
|
||||||
|
[ drop convert-general-form ]
|
||||||
|
} case ]
|
||||||
|
[ drop convert-general-form ] if ;
|
||||||
|
|
||||||
|
: convert-form ( lisp-form -- quot )
|
||||||
|
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
|
||||||
|
[ [ , ] [ ] make ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: lisp-string>factor ( str -- quot )
|
||||||
|
lisp-expr parse-result-ast convert-form ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: lisp-env
|
||||||
|
|
||||||
|
: init-env ( -- )
|
||||||
|
H{ } clone lisp-env set ;
|
||||||
|
|
||||||
|
: lisp-define ( name quot -- )
|
||||||
|
swap lisp-env get set-at ;
|
||||||
|
|
||||||
|
: lisp-get ( name -- word )
|
||||||
|
lisp-env get at ;
|
||||||
|
|
||||||
|
: funcall ( quot sym -- * )
|
||||||
|
dup lisp-symbol? [ name>> lisp-get ] when call ; inline
|
|
@ -0,0 +1 @@
|
||||||
|
James Cash
|
|
@ -0,0 +1,38 @@
|
||||||
|
! Copyright (C) 2008 James Cash
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: lisp.parser tools.test peg peg.ebnf ;
|
||||||
|
|
||||||
|
IN: lisp.parser.tests
|
||||||
|
|
||||||
|
{ 1234 } [
|
||||||
|
"1234" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ 123.98 } [
|
||||||
|
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ "" } [
|
||||||
|
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ "aoeu" } [
|
||||||
|
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ "aoeu\"de" } [
|
||||||
|
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ T{ lisp-symbol f "foobar" } } [
|
||||||
|
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ T{ lisp-symbol f "+" } } [
|
||||||
|
"+" "atom" \ lisp-expr rule parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ T{ s-exp f
|
||||||
|
V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
|
||||||
|
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
|
||||||
|
] unit-test
|
|
@ -0,0 +1,39 @@
|
||||||
|
! Copyright (C) 2008 James Cash
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
|
||||||
|
combinators.lib ;
|
||||||
|
|
||||||
|
IN: lisp.parser
|
||||||
|
|
||||||
|
TUPLE: lisp-symbol name ;
|
||||||
|
C: <lisp-symbol> lisp-symbol
|
||||||
|
|
||||||
|
TUPLE: s-exp body ;
|
||||||
|
C: <s-exp> s-exp
|
||||||
|
|
||||||
|
EBNF: lisp-expr
|
||||||
|
_ = (" " | "\t" | "\n")*
|
||||||
|
LPAREN = "("
|
||||||
|
RPAREN = ")"
|
||||||
|
dquote = '"'
|
||||||
|
squote = "'"
|
||||||
|
digit = [0-9]
|
||||||
|
integer = (digit)+ => [[ string>number ]]
|
||||||
|
float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
|
||||||
|
number = float
|
||||||
|
| integer
|
||||||
|
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
|
||||||
|
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
||||||
|
letters = [a-zA-Z] => [[ 1array >string ]]
|
||||||
|
initials = letters | id-specials
|
||||||
|
numbers = [0-9] => [[ 1array >string ]]
|
||||||
|
subsequents = initials | numbers
|
||||||
|
identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
|
||||||
|
escaped = "\" . => [[ second ]]
|
||||||
|
string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
|
||||||
|
atom = number
|
||||||
|
| identifier
|
||||||
|
| string
|
||||||
|
list-item = _ (atom|s-expression) _ => [[ second ]]
|
||||||
|
s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
|
||||||
|
;EBNF
|
|
@ -0,0 +1 @@
|
||||||
|
EBNF grammar for parsing Lisp
|
|
@ -0,0 +1,2 @@
|
||||||
|
lisp
|
||||||
|
parsing
|
|
@ -0,0 +1 @@
|
||||||
|
A Lisp interpreter in Factor
|
|
@ -0,0 +1,2 @@
|
||||||
|
lisp
|
||||||
|
languages
|
|
@ -1,7 +1,7 @@
|
||||||
USING: unicode.categories kernel math combinators splitting
|
USING: unicode.categories kernel math combinators splitting
|
||||||
sequences math.parser io.files io assocs arrays namespaces
|
sequences math.parser io.files io assocs arrays namespaces
|
||||||
math.ranges unicode.normalize unicode.syntax.backend
|
math.ranges unicode.normalize values io.encodings.ascii
|
||||||
unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
|
unicode.syntax unicode.data compiler.units alien.syntax ;
|
||||||
IN: unicode.breaks
|
IN: unicode.breaks
|
||||||
|
|
||||||
C-ENUM: Any L V T Extend Control CR LF graphemes ;
|
C-ENUM: Any L V T Extend Control CR LF graphemes ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: assocs math kernel sequences io.files hashtables
|
USING: assocs math kernel sequences io.files hashtables
|
||||||
quotations splitting arrays math.parser hash2 math.order
|
quotations splitting arrays math.parser hash2 math.order
|
||||||
byte-arrays words namespaces words compiler.units parser
|
byte-arrays words namespaces words compiler.units parser
|
||||||
io.encodings.ascii unicode.syntax.backend ;
|
io.encodings.ascii values ;
|
||||||
IN: unicode.data
|
IN: unicode.data
|
||||||
|
|
||||||
! Convenience functions
|
! Convenience functions
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: unicode.syntax.backend kernel sequences assocs io.files
|
USING: values kernel sequences assocs io.files
|
||||||
io.encodings ascii math.ranges io splitting math.parser
|
io.encodings ascii math.ranges io splitting math.parser
|
||||||
namespaces byte-arrays locals math sets io.encodings.ascii
|
namespaces byte-arrays locals math sets io.encodings.ascii
|
||||||
words compiler.units arrays interval-maps ;
|
words compiler.units arrays interval-maps ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Daniel Ehrenberg
|
|
@ -0,0 +1 @@
|
||||||
|
Global variables in the Forth value style
|
|
@ -0,0 +1 @@
|
||||||
|
extensions
|
|
@ -0,0 +1,27 @@
|
||||||
|
USING: help.markup help.syntax ;
|
||||||
|
IN: values
|
||||||
|
|
||||||
|
ARTICLE: "values" "Global values"
|
||||||
|
"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. Values abstract over this concept. To create a new word as a value, use the following syntax:"
|
||||||
|
{ $subsection POSTPONE: VALUE: }
|
||||||
|
"To get the value, just call the word. The following words manipulate values:"
|
||||||
|
{ $subsection get-value }
|
||||||
|
{ $subsection set-value }
|
||||||
|
{ $subsection change-value } ;
|
||||||
|
|
||||||
|
HELP: VALUE:
|
||||||
|
{ $syntax "VALUE: word" }
|
||||||
|
{ $values { "word" "a word to be created" } }
|
||||||
|
{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;
|
||||||
|
|
||||||
|
HELP: get-value
|
||||||
|
{ $values { "word" "a value word" } { "value" "the contents" } }
|
||||||
|
{ $description "Gets a value. This should not normally be used, unless the word is not known until runtime." } ;
|
||||||
|
|
||||||
|
HELP: set-value
|
||||||
|
{ $values { "value" "a new value" } { "word" "a value word" } }
|
||||||
|
{ $description "Sets the value word." } ;
|
||||||
|
|
||||||
|
HELP: change-value
|
||||||
|
{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } }
|
||||||
|
{ $description "Changes the value using the given quotation." } ;
|
|
@ -0,0 +1,9 @@
|
||||||
|
USING: tools.test values math ;
|
||||||
|
IN: values.tests
|
||||||
|
|
||||||
|
VALUE: foo
|
||||||
|
[ f ] [ foo ] unit-test
|
||||||
|
[ ] [ 3 \ foo set-value ] unit-test
|
||||||
|
[ 3 ] [ foo ] unit-test
|
||||||
|
[ ] [ \ foo [ 1+ ] change-value ] unit-test
|
||||||
|
[ 4 ] [ foo ] unit-test
|
8
extra/unicode/syntax/backend/backend.factor → extra/values/values.factor
Normal file → Executable file
8
extra/unicode/syntax/backend/backend.factor → extra/values/values.factor
Normal file → Executable file
|
@ -1,8 +1,14 @@
|
||||||
USING: kernel parser sequences words ;
|
USING: kernel parser sequences words ;
|
||||||
IN: unicode.syntax.backend
|
IN: values
|
||||||
|
|
||||||
: VALUE:
|
: VALUE:
|
||||||
CREATE-WORD { f } clone [ first ] curry define ; parsing
|
CREATE-WORD { f } clone [ first ] curry define ; parsing
|
||||||
|
|
||||||
: set-value ( value word -- )
|
: set-value ( value word -- )
|
||||||
word-def first set-first ;
|
word-def first set-first ;
|
||||||
|
|
||||||
|
: get-value ( word -- value )
|
||||||
|
word-def first first ;
|
||||||
|
|
||||||
|
: change-value ( word quot -- )
|
||||||
|
over >r >r get-value r> call r> set-value ; inline
|
|
@ -38,9 +38,9 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
|
||||||
{
|
{
|
||||||
GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
|
GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
|
||||||
|
|
||||||
young_size = align_page(young_size);
|
young_size = align(young_size,DECK_SIZE);
|
||||||
aging_size = align_page(aging_size);
|
aging_size = align(aging_size,DECK_SIZE);
|
||||||
tenured_size = align_page(tenured_size);
|
tenured_size = align(tenured_size,DECK_SIZE);
|
||||||
|
|
||||||
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
|
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
|
||||||
data_heap->young_size = young_size;
|
data_heap->young_size = young_size;
|
||||||
|
|
|
@ -70,7 +70,7 @@ the offset of the first object is set by the allocator. */
|
||||||
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
|
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
|
||||||
typedef u8 F_CARD;
|
typedef u8 F_CARD;
|
||||||
|
|
||||||
#define CARD_BITS 6
|
#define CARD_BITS 8
|
||||||
#define CARD_SIZE (1<<CARD_BITS)
|
#define CARD_SIZE (1<<CARD_BITS)
|
||||||
#define ADDR_CARD_MASK (CARD_SIZE-1)
|
#define ADDR_CARD_MASK (CARD_SIZE-1)
|
||||||
|
|
||||||
|
@ -81,7 +81,7 @@ DLLEXPORT CELL cards_offset;
|
||||||
|
|
||||||
typedef u8 F_DECK;
|
typedef u8 F_DECK;
|
||||||
|
|
||||||
#define DECK_BITS (CARD_BITS + 6)
|
#define DECK_BITS (CARD_BITS + 10)
|
||||||
#define DECK_SIZE (1<<DECK_BITS)
|
#define DECK_SIZE (1<<DECK_BITS)
|
||||||
#define ADDR_DECK_MASK (DECK_SIZE-1)
|
#define ADDR_DECK_MASK (DECK_SIZE-1)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue