diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 1ff04bacc2..aa7377adbf 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -482,8 +482,6 @@ PRIVATE> : make-image ( arch -- ) [ architecture set - bootstrapping? on - load-help? off "resource:/core/bootstrap/stage1.factor" run-file build-image write-image diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3ce783d620..31ba4e4b6d 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -51,6 +51,8 @@ call ! After we execute bootstrap/layouts num-types get f builtins set +bootstrapping? on + ! Create some empty vocabs where the below primitives and ! classes will go { diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index f99c8eb82f..64402ca2e1 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -13,6 +13,8 @@ vocabs.loader system debugger continuations ; "resource:core/bootstrap/primitives.factor" run-file +load-help? off + ! Create a boot quotation for the target [ [ diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 9594cf7b23..8610f490ec 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -4,8 +4,8 @@ USING: math kernel layouts system ; IN: compiler.constants ! These constants must match vm/memory.h -: card-bits 6 ; -: deck-bits 12 ; +: card-bits 8 ; +: deck-bits 18 ; : card-mark HEX: 40 HEX: 80 bitor ; ! These constants must match vm/layouts.h diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index d85c70577e..1b28f7262e 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -18,13 +18,13 @@ IN: cpu.ppc.intrinsics "obj" get operand-tag - ; : %slot-literal-any-tag - "obj" operand "scratch" operand %untag - "val" operand "scratch" operand "n" get cells ; + "obj" operand "scratch1" operand %untag + "val" operand "scratch1" operand "n" get cells ; : %slot-any - "obj" operand "scratch" operand %untag + "obj" operand "scratch1" operand %untag "offset" operand "n" operand 1 SRAWI - "scratch" operand "val" operand "offset" operand ; + "scratch1" operand "val" operand "offset" operand ; \ slot { ! Slot number is literal and the tag is known @@ -39,7 +39,7 @@ IN: cpu.ppc.intrinsics { [ %slot-literal-any-tag LWZ ] H{ { +input+ { { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } { f "val" } } } + { +scratch+ { { f "scratch1" } { f "val" } } } { +output+ { "val" } } } } @@ -47,7 +47,7 @@ IN: cpu.ppc.intrinsics { [ %slot-any LWZX ] H{ { +input+ { { f "obj" } { f "n" } } } - { +scratch+ { { f "val" } { f "scratch" } { f "offset" } } } + { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } } { +output+ { "val" } } } } @@ -61,17 +61,17 @@ IN: cpu.ppc.intrinsics : %write-barrier ( -- ) "val" get operand-immediate? "obj" get fresh-object? or [ - "scratch1" operand card-mark LI + card-mark "scratch1" operand LI ! Mark the card "val" operand load-cards-offset "obj" operand "scratch2" operand card-bits SRWI - "val" operand "scratch2" operand "val" operand STBX + "scratch2" operand "scratch1" operand "val" operand STBX ! Mark the card deck "val" operand load-decks-offset - "obj" operand "scratch" operand deck-bits SRWI - "val" operand "scratch" operand "val" operand STBX + "obj" operand "scratch2" operand deck-bits SRWI + "scratch2" operand "scratch1" operand "val" operand STBX ] unless ; \ set-slot { @@ -87,7 +87,7 @@ IN: cpu.ppc.intrinsics { [ %slot-literal-any-tag STW %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "scratch" } } } + { +scratch+ { { f "scratch1" } { f "scratch2" } } } { +clobber+ { "val" } } } } @@ -95,7 +95,7 @@ IN: cpu.ppc.intrinsics { [ %slot-any STWX %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { f "n" } } } - { +scratch+ { { f "scratch" } { f "offset" } } } + { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } } { +clobber+ { "val" } } } } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index a463fd2e40..84b0bd3e09 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ IN: io.files.tests USING: tools.test io.files io.files.private io threads kernel continuations io.encodings.ascii io.files.unique sequences -strings accessors io.encodings.utf8 ; +strings accessors io.encodings.utf8 math ; [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test @@ -43,6 +43,8 @@ strings accessors io.encodings.utf8 ; "file4" temp-file delete-file ] unit-test +[ "file5" temp-file delete-file ] ignore-errors + [ ] [ temp-directory [ "file5" touch-file @@ -50,6 +52,8 @@ strings accessors io.encodings.utf8 ; ] with-directory ] unit-test +[ "file6" temp-file delete-file ] ignore-errors + [ ] [ temp-directory [ "file6" touch-file @@ -259,3 +263,6 @@ strings accessors io.encodings.utf8 ; [ t ] [ "resource:core" absolute-path? ] unit-test [ f ] [ "" absolute-path? ] unit-test + +[ "touch-twice-test" temp-file delete-file ] ignore-errors +[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index d43599776b..bcad667c60 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces sequences sbufs strings generic splitting growable continuations io.streams.plain -io.encodings io.encodings.private math.order ; +io.encodings math.order ; IN: io.streams.string M: growable dispose drop ; @@ -77,6 +77,3 @@ M: plain-writer stream-write-table [ drop format-table [ print ] each ] with-output-stream* ; M: plain-writer make-cell-stream 2drop ; - -M: growable stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 0e33ccd94c..122b7f1d59 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -4,7 +4,7 @@ words ; IN: threads.tests 3 "x" set -namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop +[ 2 "x" set ] "Test" spawn drop [ 2 ] [ yield "x" get ] unit-test [ ] [ [ flush ] "flush test" spawn drop flush ] unit-test [ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 138b1ef928..b640cc6384 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -136,9 +136,9 @@ SYMBOL: visited [ reset-on-redefine reset-props ] [ dup visited get set-at ] [ - crossref get at keys [ word? ] filter [ - reset-on-redefine [ word-prop ] with contains? - ] filter + crossref get at keys + [ word? ] filter + [ reset-on-redefine [ word-prop ] with contains? ] filter [ (redefined) ] each ] tri ] if ; diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index c1d7e1e4ab..d4d34f0bd0 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -13,11 +13,12 @@ PROTOCOL: assoc-protocol delete-at clear-assoc new-assoc assoc-like ; PROTOCOL: input-stream-protocol - stream-read1 stream-read stream-read-until stream-read-quot ; + stream-read1 stream-read stream-read-partial stream-readln + stream-read-until stream-read-quot ; PROTOCOL: output-stream-protocol stream-flush stream-write1 stream-write stream-format - stream-nl make-span-stream make-block-stream stream-readln + stream-nl make-span-stream make-block-stream make-cell-stream stream-write-table ; PROTOCOL: definition-protocol diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor index 7dcb9466cc..904b76ce94 100755 --- a/extra/interval-maps/interval-maps.factor +++ b/extra/interval-maps/interval-maps.factor @@ -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 ; IN: interval-maps TUPLE: interval-map array ; > from>> first <=> ] binsearch ; + [ from>> <=> ] binsearch ; -GENERIC: >interval ( object -- interval ) -M: number >interval [a,a] ; -M: sequence >interval first2 [a,b] ; -M: interval >interval ; +: interval-contains? ( object interval-node -- ? ) + [ from>> ] [ to>> ] bi between? ; : 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 ) - dup keys [ interval-intersect not ] monotonic? + dup [ disjoint? ] monotonic? [ "Intervals are not disjoint" throw ] unless ; - +: >intervals ( specification -- intervals ) + [ >r first2 r> interval-node boa ] { } assoc>map ; PRIVATE> : interval-at* ( key map -- value ? ) array>> [ find-interval ] 2keep swapd nth - [ nip value>> ] [ interval>> interval-contains? ] 2bi + [ nip value>> ] [ interval-contains? ] 2bi fixup-value ; : interval-at ( key map -- value ) interval-at* drop ; : interval-key? ( key map -- ? ) interval-at* nip ; : ( specification -- map ) - all-intervals { } assoc-like - [ [ first to>> ] compare ] sort ensure-disjoint - [ interval-node boa ] { } assoc>map + all-intervals [ [ first second ] compare ] sort + >intervals ensure-disjoint >tuple-array interval-map boa ; :: coalesce ( alist -- specification ) diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor old mode 100644 new mode 100755 index 24badaf683..dd429c1670 --- a/extra/io/encodings/iana/iana.factor +++ b/extra/io/encodings/iana/iana.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel strings unicode.syntax.backend io.files assocs -splitting sequences io namespaces sets -io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ; +USING: kernel strings values io.files assocs +splitting sequences io namespaces sets io.encodings.8-bit +io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ; IN: io.encodings.iana + stream-readln +] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index b361974a20..28e08d4bf2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -45,10 +45,9 @@ M: unix (file-appender) ( path -- stream ) M: unix touch-file ( path -- ) normalize-path - dup exists? - [ f utime ] - [ touch-mode file-mode open close ] - if ; + dup exists? [ f utime ] [ + touch-mode file-mode open close + ] if ; M: unix move-file ( from to -- ) [ normalize-path ] bi@ rename io-error ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 85c5a8dbaf..58e2b1f882 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! 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 opengl.gl opengl.glu sequences ; IN: jamshred.gl @@ -37,10 +37,6 @@ IN: jamshred.gl : draw-tunnel ( player -- ) 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 -- ) GL_DEPTH_TEST glEnable 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 ; : player-view ( player -- ) - [ oint-location first3 ] keep - [ dup oint-location swap oint-forward v+ first3 ] keep - oint-up first3 gluLookAt ; + [ location>> first3 ] + [ [ location>> ] [ forward>> ] bi v+ first3 ] + [ up>> first3 ] tri gluLookAt ; : draw-jamshred ( jamshred width height -- ) init-graphics jamshred-player dup player-view draw-tunnel ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 139cdbfb53..f3fa9a0354 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -127,7 +127,9 @@ C: segment [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; : 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 ; : distance-to-collision ( oint segment -- distance ) diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor index cdebfc4325..e5155a786e 100755 --- a/extra/lcs/lcs.factor +++ b/extra/lcs/lcs.factor @@ -7,7 +7,7 @@ IN: lcs 0 1 ? + >r [ 1+ ] bi@ r> min min ; : 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 -- ) i j 1+ matrix nth nth ! insertion @@ -25,10 +25,9 @@ IN: lcs :: run-lcs ( old new init step -- matrix ) [let | matrix [ old length 1+ new length 1+ init call ] | - old length [0,b) [| i | - new length [0,b) - [| j | i j matrix old new step loop-step ] - each + old length [| i | + new length + [| j | i j matrix old new step loop-step ] each ] each matrix ] ; inline PRIVATE> diff --git a/extra/lisp/authors.txt b/extra/lisp/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lisp/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor new file mode 100644 index 0000000000..ec376569f0 --- /dev/null +++ b/extra/lisp/lisp-tests.factor @@ -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 \ No newline at end of file diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor new file mode 100644 index 0000000000..7d4b9af02a --- /dev/null +++ b/extra/lisp/lisp.factor @@ -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 ; + +> swap member? [ name>> make-local ] [ ] if ] + [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if + ] with map ; + +: localize-lambda ( body vars -- newbody newvars ) + dup make-locals dup push-locals [ swap localize-body 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 ] 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 \ No newline at end of file diff --git a/extra/lisp/parser/authors.txt b/extra/lisp/parser/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lisp/parser/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor new file mode 100644 index 0000000000..9e6b54ab0c --- /dev/null +++ b/extra/lisp/parser/parser-tests.factor @@ -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 \ No newline at end of file diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor new file mode 100644 index 0000000000..65ad01aa6f --- /dev/null +++ b/extra/lisp/parser/parser.factor @@ -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 + +TUPLE: s-exp body ; +C: 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 ]] +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 ]] +;EBNF \ No newline at end of file diff --git a/extra/lisp/parser/summary.txt b/extra/lisp/parser/summary.txt new file mode 100644 index 0000000000..aa407b3dfb --- /dev/null +++ b/extra/lisp/parser/summary.txt @@ -0,0 +1 @@ +EBNF grammar for parsing Lisp diff --git a/extra/lisp/parser/tags.txt b/extra/lisp/parser/tags.txt new file mode 100644 index 0000000000..d1f6fa1ef3 --- /dev/null +++ b/extra/lisp/parser/tags.txt @@ -0,0 +1,2 @@ +lisp +parsing diff --git a/extra/lisp/summary.txt b/extra/lisp/summary.txt new file mode 100644 index 0000000000..8c36217f1c --- /dev/null +++ b/extra/lisp/summary.txt @@ -0,0 +1 @@ +A Lisp interpreter in Factor diff --git a/extra/lisp/tags.txt b/extra/lisp/tags.txt new file mode 100644 index 0000000000..c369ccae57 --- /dev/null +++ b/extra/lisp/tags.txt @@ -0,0 +1,2 @@ +lisp +languages diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 162512f9f3..5d350d80c4 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -68,7 +68,9 @@ IN: smtp.tests rot from>> ] unit-test -[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test +[ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test + +[ ] [ yield ] unit-test [ ] [ [ @@ -85,3 +87,5 @@ IN: smtp.tests send-email ] with-scope ] unit-test + +[ ] [ yield ] unit-test diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index 038bfde70d..0c77a52f94 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -1,6 +1,6 @@ USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs namespaces kernel words compiler.units sequences -ui.cocoa ; +ui ui.cocoa ; "stop-after-last-window?" get global [ diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor old mode 100644 new mode 100755 index 9635a62e49..7ef97d553c --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,7 +1,7 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces -math.ranges unicode.normalize unicode.syntax.backend -unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ; +math.ranges unicode.normalize values io.encodings.ascii +unicode.syntax unicode.data compiler.units alien.syntax ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index f33338137a..52706647a9 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,7 +1,7 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser hash2 math.order byte-arrays words namespaces words compiler.units parser -io.encodings.ascii unicode.syntax.backend ; +io.encodings.ascii values ; IN: unicode.data ! Convenience functions diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index d0bb4ac30d..846f797f71 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -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 namespaces byte-arrays locals math sets io.encodings.ascii words compiler.units arrays interval-maps ; diff --git a/extra/values/authors.txt b/extra/values/authors.txt new file mode 100755 index 0000000000..504363d316 --- /dev/null +++ b/extra/values/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/values/summary.txt b/extra/values/summary.txt new file mode 100755 index 0000000000..7caab7412d --- /dev/null +++ b/extra/values/summary.txt @@ -0,0 +1 @@ +Global variables in the Forth value style diff --git a/extra/values/tags.txt b/extra/values/tags.txt new file mode 100755 index 0000000000..187b6926c1 --- /dev/null +++ b/extra/values/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/values/values-docs.factor b/extra/values/values-docs.factor new file mode 100755 index 0000000000..4984b03f03 --- /dev/null +++ b/extra/values/values-docs.factor @@ -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." } ; diff --git a/extra/values/values-tests.factor b/extra/values/values-tests.factor new file mode 100755 index 0000000000..31b44be99e --- /dev/null +++ b/extra/values/values-tests.factor @@ -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 diff --git a/extra/unicode/syntax/backend/backend.factor b/extra/values/values.factor old mode 100644 new mode 100755 similarity index 52% rename from extra/unicode/syntax/backend/backend.factor rename to extra/values/values.factor index 5c463e8fc4..0d1ea3bc04 --- a/extra/unicode/syntax/backend/backend.factor +++ b/extra/values/values.factor @@ -1,8 +1,14 @@ USING: kernel parser sequences words ; -IN: unicode.syntax.backend +IN: values : VALUE: CREATE-WORD { f } clone [ first ] curry define ; parsing : set-value ( value word -- ) 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 diff --git a/vm/data_gc.c b/vm/data_gc.c index f44b8a7a05..6e32e14991 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -7,6 +7,8 @@ #define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n" #define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n" +/* #define GC_DEBUG */ + #ifdef GC_DEBUG #define GC_PRINT printf #else @@ -23,7 +25,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start) void init_card_decks(void) { - CELL start = data_heap->segment->start & ~(DECK_SIZE - 1); + CELL start = align(data_heap->segment->start,DECK_SIZE); allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS); cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS); decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS); @@ -36,9 +38,9 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, { GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size); - young_size = align_page(young_size); - aging_size = align_page(aging_size); - tenured_size = align_page(tenured_size); + young_size = align(young_size,DECK_SIZE); + aging_size = align(aging_size,DECK_SIZE); + tenured_size = align(tenured_size,DECK_SIZE); F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP)); data_heap->young_size = young_size; @@ -59,23 +61,25 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, return NULL; /* can't happen */ } + total_size += DECK_SIZE; + data_heap->segment = alloc_segment(total_size); data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); - CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE; + CELL cards_size = total_size >> CARD_BITS; data_heap->allot_markers = safe_malloc(cards_size); data_heap->allot_markers_end = data_heap->allot_markers + cards_size; data_heap->cards = safe_malloc(cards_size); data_heap->cards_end = data_heap->cards + cards_size; - CELL decks_size = (total_size + DECK_SIZE) / DECK_SIZE; + CELL decks_size = total_size >> DECK_BITS; data_heap->decks = safe_malloc(decks_size); data_heap->decks_end = data_heap->decks + decks_size; - CELL alloter = data_heap->segment->start; + CELL alloter = align(data_heap->segment->start,DECK_SIZE); alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter); @@ -92,7 +96,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter); } - if(alloter != data_heap->segment->end) + if(data_heap->segment->end - alloter > DECK_SIZE) critical_error("Bug in alloc_data_heap",alloter); return data_heap; @@ -119,8 +123,6 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap) free(data_heap); } -/* Every card stores the offset of the first object in that card, which must be -cleared when a generation has been cleared */ void clear_cards(CELL from, CELL to) { /* NOTE: reverse order due to heap layout. */ @@ -133,9 +135,9 @@ void clear_cards(CELL from, CELL to) void clear_decks(CELL from, CELL to) { /* NOTE: reverse order due to heap layout. */ - F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start); - F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end); - F_CARD *ptr; + F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start); + F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end); + F_DECK *ptr; for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0; } @@ -145,7 +147,7 @@ void clear_allot_markers(CELL from, CELL to) F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start); F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end); F_CARD *ptr; - for(ptr = first_card; ptr < last_card; ptr++) *ptr = CARD_BASE_MASK; + for(ptr = first_card; ptr < last_card; ptr++) *ptr = INVALID_ALLOT_MARKER; } void set_data_heap(F_DATA_HEAP *data_heap_) @@ -163,6 +165,10 @@ void gc_reset(void) int i; for(i = 0; i < MAX_GEN_COUNT; i++) memset(&gc_stats[i],0,sizeof(F_GC_STATS)); + + cards_scanned = 0; + decks_scanned = 0; + code_heap_scans = 0; } void init_data_heap(CELL gens, @@ -182,10 +188,6 @@ void init_data_heap(CELL gens, secure_gc = secure_gc_; gc_reset(); - - cards_scanned = 0; - decks_scanned = 0; - code_heap_scans = 0; } /* Size of the object pointed to by a tagged pointer */ @@ -328,8 +330,11 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here) { CELL offset = CARD_OFFSET(ptr); - if(offset != CARD_BASE_MASK) + if(offset != INVALID_ALLOT_MARKER) { + if(offset & TAG_MASK) + critical_error("Bad card",(CELL)ptr); + CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset; CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); diff --git a/vm/data_gc.h b/vm/data_gc.h index 20692c14e6..3c21695c2c 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -68,26 +68,21 @@ the offset of the first object is set by the allocator. */ #define CARD_POINTS_TO_NURSERY 0x80 #define CARD_POINTS_TO_AGING 0x40 #define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) -#define CARD_BASE_MASK 0x3f typedef u8 F_CARD; -/* A card is 64 bytes. 6 bits is sufficient to represent every -offset within the card */ -#define CARD_SIZE 64 -#define CARD_BITS 6 +#define CARD_BITS 8 +#define CARD_SIZE (1<> CARD_BITS) + cards_offset) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> CARD_BITS) + allot_markers_offset) #define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers)) +#define INVALID_ALLOT_MARKER 0xff + +DLLEXPORT CELL allot_markers_offset; + void init_card_decks(void); -/* this is an inefficient write barrier. compiled definitions use a more -efficient one hand-coded in assembly. the write barrier must be called -any time we are potentially storing a pointer from an older generation -to a younger one */ +/* the write barrier must be called any time we are potentially storing a +pointer from an older generation to a younger one */ INLINE void write_barrier(CELL address) { *ADDR_TO_CARD(address) = CARD_MARK_MASK; @@ -124,9 +121,8 @@ INLINE void set_slot(CELL obj, CELL slot, CELL value) INLINE void allot_barrier(CELL address) { F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); - F_CARD b = *ptr; - F_CARD a = (address & ADDR_CARD_MASK); - *ptr = (b < a ? b : a); + if(*ptr == INVALID_ALLOT_MARKER) + *ptr = (address & ADDR_CARD_MASK); } void clear_cards(CELL from, CELL to); diff --git a/vm/run.h b/vm/run.h index e2afb08525..cc980453cf 100755 --- a/vm/run.h +++ b/vm/run.h @@ -103,11 +103,11 @@ INLINE void bput(CELL where, CELL what) INLINE CELL align(CELL a, CELL b) { - return (a + b) & ~b; + return (a + (b-1)) & ~(b-1); } -#define align8(a) align(a,7) -#define align_page(a) align(a,getpagesize() - 1) +#define align8(a) align(a,8) +#define align_page(a) align(a,getpagesize()) /* Canonical T object. It's just a word */ CELL T;