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

Merge branch 'master' of git://factorcode.org/git/factor 

Conflicts:

	extra/delegate/protocols/protocols.factor
db4
Daniel Ehrenberg 2008-05-10 15:14:58 -05:00
parent 85627883de d33b57506a
commit 46b4167a24
39 changed files with 449 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/bootstrap/image/image.factor
View File

@ -482,8 +482,6 @@ PRIVATE>
: make-image ( arch -- ) : make-image ( arch -- )
[ [
architecture set architecture set
bootstrapping? on
load-help? off
"resource:/core/bootstrap/stage1.factor" run-file "resource:/core/bootstrap/stage1.factor" run-file
build-image build-image
write-image write-image

2
core/bootstrap/primitives.factor
View File

@ -51,6 +51,8 @@ call
! After we execute bootstrap/layouts ! After we execute bootstrap/layouts
num-types get f <array> builtins set num-types get f <array> builtins set
bootstrapping? on
! Create some empty vocabs where the below primitives and ! Create some empty vocabs where the below primitives and
! classes will go ! classes will go
{ {

2
core/bootstrap/stage1.factor
View File

@ -13,6 +13,8 @@ vocabs.loader system debugger continuations ;
"resource:core/bootstrap/primitives.factor" run-file "resource:core/bootstrap/primitives.factor" run-file
load-help? off
! Create a boot quotation for the target ! Create a boot quotation for the target
[ [
[ [

4
core/compiler/constants/constants.factor
View File

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

24
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -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
"val" 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 "scratch" operand deck-bits SRWI "obj" operand "scratch2" operand deck-bits SRWI
"val" operand "scratch" 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" } }
} }
} }

9
core/io/files/files-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.files.tests IN: io.files.tests
USING: tools.test io.files io.files.private io threads kernel USING: tools.test io.files io.files.private io threads kernel
continuations io.encodings.ascii io.files.unique sequences 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 dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test
@ -43,6 +43,8 @@ strings accessors io.encodings.utf8 ;
"file4" temp-file delete-file "file4" temp-file delete-file
] unit-test ] unit-test
[ "file5" temp-file delete-file ] ignore-errors
[ ] [ [ ] [
temp-directory [ temp-directory [
"file5" touch-file "file5" touch-file
@ -50,6 +52,8 @@ strings accessors io.encodings.utf8 ;
] with-directory ] with-directory
] unit-test ] unit-test
[ "file6" temp-file delete-file ] ignore-errors
[ ] [ [ ] [
temp-directory [ temp-directory [
"file6" touch-file "file6" touch-file
@ -259,3 +263,6 @@ strings accessors io.encodings.utf8 ;
[ t ] [ "resource:core" absolute-path? ] unit-test [ t ] [ "resource:core" absolute-path? ] unit-test
[ f ] [ "" 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

5
core/io/streams/string/string.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain generic splitting growable continuations io.streams.plain
io.encodings io.encodings.private math.order ; io.encodings math.order ;
IN: io.streams.string IN: io.streams.string
M: growable dispose drop ; M: growable dispose drop ;
@ -77,6 +77,3 @@ M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ; [ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ; M: plain-writer make-cell-stream 2drop <string-writer> ;
M: growable stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;

2
core/threads/threads-tests.factor
View File

@ -4,7 +4,7 @@ words ;
IN: threads.tests IN: threads.tests
3 "x" set 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 [ 2 ] [ yield "x" get ] unit-test
[ ] [ [ flush ] "flush test" spawn drop flush ] unit-test [ ] [ [ flush ] "flush test" spawn drop flush ] unit-test
[ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test [ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test

6
core/words/words.factor
View File

@ -136,9 +136,9 @@ SYMBOL: visited
[ reset-on-redefine reset-props ] [ reset-on-redefine reset-props ]
[ dup visited get set-at ] [ dup visited get set-at ]
[ [
crossref get at keys [ word? ] filter [ crossref get at keys
reset-on-redefine [ word-prop ] with contains? [ word? ] filter
] filter [ reset-on-redefine [ word-prop ] with contains? ] filter
[ (redefined) ] each [ (redefined) ] each
] tri ] tri
] if ; ] if ;

2
extra/builder/report/report.factor
View File

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

6
extra/delegate/protocols/protocols.factor
View File

@ -16,12 +16,12 @@ PROTOCOL: assoc-protocol
assoc-like ; assoc-like ;
PROTOCOL: input-stream-protocol PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-until stream-read1 stream-read stream-read-partial stream-readln
stream-read-quot ; stream-read-until stream-read-quot ;
PROTOCOL: output-stream-protocol PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format 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 ; make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol PROTOCOL: definition-protocol

8
extra/io/streams/duplex/duplex-tests.factor
View File

@ -1,4 +1,5 @@
USING: io.streams.duplex io kernel continuations tools.test ; USING: io.streams.duplex io io.streams.string
kernel continuations tools.test ;
IN: io.streams.duplex.tests IN: io.streams.duplex.tests
! Test duplex stream close behavior ! Test duplex stream close behavior
@ -38,3 +39,8 @@ M: unclosable-stream dispose
[ dup dispose ] [ 2drop ] recover [ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed? ] keep closing-stream-closed?
] unit-test ] unit-test
[ "Hey" ] [
"Hey\nThere" <string-reader> <string-writer> <duplex-stream>
stream-readln
] unit-test

2
extra/io/unix/backend/backend.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien generic assocs kernel kernel.private math USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix io.nonblocking sequences strings structs sbufs threads unix.ffi unix
vectors io.buffers io.backend io.encodings math.parser vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces io.timeouts continuations system libc qualified namespaces io.timeouts
io.encodings.utf8 accessors ; io.encodings.utf8 accessors ;

7
extra/io/unix/files/files.factor
View File

@ -45,10 +45,9 @@ M: unix (file-appender) ( path -- stream )
M: unix touch-file ( path -- ) M: unix touch-file ( path -- )
normalize-path normalize-path
dup exists? dup exists? [ f utime ] [
[ f utime ] touch-mode file-mode open close
[ touch-mode file-mode open close ] ] if ;
if ;
M: unix move-file ( from to -- ) M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ; [ normalize-path ] bi@ rename io-error ;

2
extra/io/unix/kqueue/kqueue.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: alien.c-types kernel math math.bitfields namespaces USING: alien.c-types kernel math math.bitfields namespaces
locals accessors combinators threads vectors hashtables locals accessors combinators threads vectors hashtables
sequences assocs continuations sets sequences assocs continuations sets
unix unix.time unix.kqueue unix.process unix.ffi unix unix.time unix.kqueue unix.process
io.nonblocking io.unix.backend io.launcher io.unix.launcher io.nonblocking io.unix.backend io.launcher io.unix.launcher
io.monitors ; io.monitors ;
IN: io.unix.kqueue IN: io.unix.kqueue

2
extra/io/unix/sockets/sockets.factor
View File

@ -5,7 +5,7 @@ namespaces threads sequences byte-arrays io.nonblocking
io.binary io.unix.backend io.streams.duplex io.sockets.impl io.binary io.unix.backend io.streams.duplex io.sockets.impl
io.backend io.files io.files.private io.encodings.utf8 io.backend io.files io.files.private io.encodings.utf8
math.parser continuations libc combinators system accessors math.parser continuations libc combinators system accessors
qualified unix ; qualified unix.ffi unix ;
EXCLUDE: io => read write close ; EXCLUDE: io => read write close ;
EXCLUDE: io.sockets => accept ; EXCLUDE: io.sockets => accept ;

12
extra/jamshred/gl/gl.factor
View File

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

4
extra/jamshred/tunnel/tunnel.factor
View File

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

1
extra/lisp/authors.txt Normal file
View File

@ -0,0 +1 @@
James Cash

21
extra/lisp/lisp-tests.factor Normal file
View File

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

88
extra/lisp/lisp.factor Normal file
View File

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

1
extra/lisp/parser/authors.txt Normal file
View File

@ -0,0 +1 @@
James Cash

38
extra/lisp/parser/parser-tests.factor Normal file
View File

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

39
extra/lisp/parser/parser.factor Normal file
View File

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

1
extra/lisp/parser/summary.txt Normal file
View File

@ -0,0 +1 @@
EBNF grammar for parsing Lisp

2
extra/lisp/parser/tags.txt Normal file
View File

@ -0,0 +1,2 @@
lisp
parsing

1
extra/lisp/summary.txt Normal file
View File

@ -0,0 +1 @@
A Lisp interpreter in Factor

2
extra/lisp/tags.txt Normal file
View File

@ -0,0 +1,2 @@
lisp
languages

60
extra/math/miller-rabin/miller-rabin.factor
View File

@ -3,21 +3,9 @@ math.functions math.ranges namespaces random sequences
hashtables sets ; hashtables sets ;
IN: math.miller-rabin IN: math.miller-rabin
SYMBOL: a : >even ( n -- int ) dup even? [ 1- ] unless ; foldable
SYMBOL: n : >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
SYMBOL: r : next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
SYMBOL: s
SYMBOL: count
SYMBOL: trials
: >even ( n -- int )
dup even? [ 1- ] unless ; foldable
: >odd ( n -- int )
dup even? [ 1+ ] when ; foldable
: next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ;
TUPLE: positive-even-expected n ; TUPLE: positive-even-expected n ;
@ -28,34 +16,30 @@ TUPLE: positive-even-expected n ;
#! factor an integer into s * 2^r #! factor an integer into s * 2^r
0 swap (factor-2s) ; 0 swap (factor-2s) ;
:: (miller-rabin) ( n prime?! -- ? ) :: (miller-rabin) ( n trials -- ? )
n 1- factor-2s s set r set [let | r [ n 1- factor-2s drop ]
trials get [ s [ n 1- factor-2s nip ]
n 1- [1,b] random a set prime?! [ t ]
a get s get n ^mod 1 = [ a! [ 0 ]
0 count set count! [ 0 ] |
r get [ trials [
2^ s get * a get swap n ^mod n - -1 = [ n 1- [1,b] random a!
count [ 1+ ] change a s n ^mod 1 = [
r get + 0 count!
] when r [
2^ s * a swap n ^mod n - -1 =
[ count 1+ count! r + ] when
] each ] each
count get zero? [ count zero? [ f prime?! trials + ] when
f prime?! ] unless drop
trials get + ] each prime? ] ;
] when
] unless
drop
] each prime? ;
TUPLE: miller-rabin-bounds ;
: miller-rabin* ( n numtrials -- ? ) : miller-rabin* ( n numtrials -- ? )
over { over {
{ [ dup 1 <= ] [ 3drop f ] } { [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] } { [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] } { [ dup even? ] [ 3drop f ] }
[ [ drop trials set t (miller-rabin) ] with-scope ] [ [ drop (miller-rabin) ] with-scope ]
} cond ; } cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ; : miller-rabin ( n -- ? ) 10 miller-rabin* ;
@ -66,7 +50,11 @@ TUPLE: miller-rabin-bounds ;
: random-prime ( numbits -- p ) : random-prime ( numbits -- p )
random-bits next-prime ; random-bits next-prime ;
ERROR: no-relative-prime n ;
: (find-relative-prime) ( n guess -- p ) : (find-relative-prime) ( n guess -- p )
over 1 <= [ over no-relative-prime ] when
dup 1 <= [ drop 3 ] when
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ; 2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
: find-relative-prime* ( n guess -- p ) : find-relative-prime* ( n guess -- p )

6
extra/smtp/smtp-tests.factor
View File

@ -68,7 +68,9 @@ IN: smtp.tests
rot from>> rot from>>
] unit-test ] 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 send-email
] with-scope ] with-scope
] unit-test ] unit-test
[ ] [ yield ] unit-test

190
extra/tar/tar.factor
View File

@ -1,99 +1,92 @@
USING: combinators io io.files io.streams.string kernel math USING: combinators io io.files io.streams.string kernel math
math.parser continuations namespaces pack prettyprint sequences math.parser continuations namespaces pack prettyprint sequences
strings system hexdump io.encodings.binary inspector accessors ; strings system hexdump io.encodings.binary inspector accessors
io.backend symbols byte-arrays ;
IN: tar IN: tar
: zero-checksum 256 ; : zero-checksum 256 ; inline
: block-size 512 ; inline
TUPLE: tar-header name mode uid gid size mtime checksum typeflag TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ; linkname magic version uname gname devmajor devminor prefix ;
ERROR: checksum-error ;
: <tar-header> ( -- obj ) tar-header new ; SYMBOLS: base-dir filename ;
: tar-trim ( seq -- newseq ) : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
[ "\0 " member? ] trim ;
: read-tar-header ( -- obj ) : read-tar-header ( -- obj )
<tar-header> \ tar-header new
100 read-c-string* over set-tar-header-name 100 read-c-string* >>name
8 read-c-string* tar-trim oct> over set-tar-header-mode 8 read-c-string* tar-trim oct> >>mode
8 read-c-string* tar-trim oct> over set-tar-header-uid 8 read-c-string* tar-trim oct> >>uid
8 read-c-string* tar-trim oct> over set-tar-header-gid 8 read-c-string* tar-trim oct> >>gid
12 read-c-string* tar-trim oct> over set-tar-header-size 12 read-c-string* tar-trim oct> >>size
12 read-c-string* tar-trim oct> over set-tar-header-mtime 12 read-c-string* tar-trim oct> >>mtime
8 read-c-string* tar-trim oct> over set-tar-header-checksum 8 read-c-string* tar-trim oct> >>checksum
read1 over set-tar-header-typeflag read1 >>typeflag
100 read-c-string* over set-tar-header-linkname 100 read-c-string* >>linkname
6 read over set-tar-header-magic 6 read >>magic
2 read over set-tar-header-version 2 read >>version
32 read-c-string* over set-tar-header-uname 32 read-c-string* >>uname
32 read-c-string* over set-tar-header-gname 32 read-c-string* >>gname
8 read tar-trim oct> over set-tar-header-devmajor 8 read tar-trim oct> >>devmajor
8 read tar-trim oct> over set-tar-header-devminor 8 read tar-trim oct> >>devminor
155 read-c-string* over set-tar-header-prefix ; 155 read-c-string* >>prefix ;
: header-checksum ( seq -- x ) : header-checksum ( seq -- x )
148 cut-slice 8 tail-slice 148 cut-slice 8 tail-slice
[ sum ] bi@ + 256 + ; [ sum ] bi@ + 256 + ;
TUPLE: checksum-error ; : read-data-blocks ( tar-header -- )
TUPLE: malformed-block-error ; dup size>> 0 > [
block-size read [
SYMBOL: base-dir over size>> dup block-size <= [
SYMBOL: out-stream head-slice >byte-array write drop
SYMBOL: filename
: (read-data-blocks) ( tar-header -- )
512 read [
over tar-header-size dup 512 <= [
head-slice
>string write
drop
] [ ] [
drop drop write
>string write [ block-size - ] change-size
dup tar-header-size 512 - over set-tar-header-size read-data-blocks
(read-data-blocks)
] if ] if
] [ ] [
drop drop
] if* ; ] if*
] [
: read-data-blocks ( tar-header out -- ) drop
[ (read-data-blocks) ] with-output-stream* ; ] if ;
: parse-tar-header ( seq -- obj ) : parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [ [ header-checksum ] keep over zero-checksum = [
2drop 2drop
\ tar-header new \ tar-header new
0 over set-tar-header-size 0 >>size
0 over set-tar-header-checksum 0 >>checksum
] [ ] [
[ read-tar-header ] with-string-reader [ read-tar-header ] with-string-reader
[ tar-header-checksum = [ [ checksum>> = [ checksum-error ] unless ] keep
\ checksum-error new throw
] unless
] keep
] if ; ] if ;
ERROR: unknown-typeflag ch ; ERROR: unknown-typeflag ch ;
M: unknown-typeflag summary ( obj -- str ) M: unknown-typeflag summary ( obj -- str )
ch>> 1string ch>> 1string "Unknown typeflag: " prepend ;
"Unknown typeflag: " prepend ;
: tar-append-path ( path -- newpath ) : tar-prepend-path ( path -- newpath )
base-dir get prepend-path ; base-dir get prepend-path ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
! Normal file ! Normal file
: typeflag-0 : typeflag-0 ( header -- )
name>> tar-append-path binary <file-writer> dup name>> tar-prepend-path read/write-blocks ;
[ read-data-blocks ] keep dispose ;
! Hard link ! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ; : typeflag-1 ( header -- ) unknown-typeflag ;
! Symlink ! Symlink
: typeflag-2 ( header -- ) unknown-typeflag ; : typeflag-2 ( header -- )
[ name>> ] [ linkname>> ] bi
[ make-link ] 2curry ignore-errors ;
! character special ! character special
: typeflag-3 ( header -- ) unknown-typeflag ; : typeflag-3 ( header -- ) unknown-typeflag ;
@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str )
! Directory ! Directory
: typeflag-5 ( header -- ) : typeflag-5 ( header -- )
tar-header-name tar-append-path make-directories ; name>> tar-prepend-path make-directories ;
! FIFO ! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ; : typeflag-6 ( header -- ) unknown-typeflag ;
@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-9 ( header -- ) unknown-typeflag ; : typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header ! Global POSIX header
: typeflag-g ( header -- ) unknown-typeflag ; : typeflag-g ( header -- ) typeflag-0 ;
! Extended POSIX header ! Extended POSIX header
: typeflag-x ( header -- ) unknown-typeflag ; : typeflag-x ( header -- ) unknown-typeflag ;
@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str )
! Long file name ! Long file name
: typeflag-L ( header -- ) : typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep drop ;
>string [ zero? ] right-trim filename set ! <string-writer> [ read-data-blocks ] keep
global [ "long filename: " write filename get . flush ] bind ! >string [ zero? ] right-trim filename set
filename get tar-append-path make-directories ; ! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry ! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ; : typeflag-M ( header -- ) unknown-typeflag ;
@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-X ( header -- ) unknown-typeflag ; : typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- ) : (parse-tar) ( -- )
512 read block-size read dup length 512 = [
global [ dup hexdump. flush ] bind
[
parse-tar-header parse-tar-header
! global [ dup tar-header-name [ print flush ] when* ] bind dup typeflag>>
dup tar-header-typeflag
{ {
{ 0 [ typeflag-0 ] } { 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] } { CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] } ! { CHAR: 1 [ typeflag-1 ] }
{ CHAR: 2 [ typeflag-2 ] } { CHAR: 2 [ typeflag-2 ] }
{ CHAR: 3 [ typeflag-3 ] } ! { CHAR: 3 [ typeflag-3 ] }
{ CHAR: 4 [ typeflag-4 ] } ! { CHAR: 4 [ typeflag-4 ] }
{ CHAR: 5 [ typeflag-5 ] } { CHAR: 5 [ typeflag-5 ] }
{ CHAR: 6 [ typeflag-6 ] } ! { CHAR: 6 [ typeflag-6 ] }
{ CHAR: 7 [ typeflag-7 ] } ! { CHAR: 7 [ typeflag-7 ] }
{ CHAR: g [ typeflag-g ] } { CHAR: g [ typeflag-g ] }
{ CHAR: x [ typeflag-x ] } ! { CHAR: x [ typeflag-x ] }
{ CHAR: A [ typeflag-A ] } ! { CHAR: A [ typeflag-A ] }
{ CHAR: D [ typeflag-D ] } ! { CHAR: D [ typeflag-D ] }
{ CHAR: E [ typeflag-E ] } ! { CHAR: E [ typeflag-E ] }
{ CHAR: I [ typeflag-I ] } ! { CHAR: I [ typeflag-I ] }
{ CHAR: K [ typeflag-K ] } ! { CHAR: K [ typeflag-K ] }
{ CHAR: L [ typeflag-L ] } ! { CHAR: L [ typeflag-L ] }
{ CHAR: M [ typeflag-M ] } ! { CHAR: M [ typeflag-M ] }
{ CHAR: N [ typeflag-N ] } ! { CHAR: N [ typeflag-N ] }
{ CHAR: S [ typeflag-S ] } ! { CHAR: S [ typeflag-S ] }
{ CHAR: V [ typeflag-V ] } ! { CHAR: V [ typeflag-V ] }
{ CHAR: X [ typeflag-X ] } ! { CHAR: X [ typeflag-X ] }
[ unknown-typeflag ] { f [ drop ] }
} case } case (parse-tar)
! dup tar-header-size zero? [ ] [
! out-stream get [ dispose ] when drop
! out-stream off ] if ;
! drop
! ] [
! dup tar-header-name
! dup parent-dir base-dir prepend-path
! global [ dup [ . flush ] when* ] bind
! make-directories <file-writer>
! out-stream set
! read-tar-blocks
! ] if
(parse-tar)
] when* ;
: parse-tar ( path -- obj ) : parse-tar ( path -- )
binary [ normalize-path dup parent-directory base-dir [
"resource:tar-test" base-dir set binary [ (parse-tar) ] with-file-reader
global [ nl nl nl "Starting to parse .tar..." print flush ] bind ] with-variable ;
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
] with-file-writer ;

2
extra/tools/deploy/shaker/strip-cocoa.factor
View File

@ -1,6 +1,6 @@
USING: cocoa cocoa.messages cocoa.application cocoa.nibs USING: cocoa cocoa.messages cocoa.application cocoa.nibs
assocs namespaces kernel words compiler.units sequences assocs namespaces kernel words compiler.units sequences
ui.cocoa ; ui ui.cocoa ;
"stop-after-last-window?" get "stop-after-last-window?" get
global [ global [

3
extra/unix/ffi/ffi.factor
View File

@ -10,3 +10,6 @@ C-STRUCT: utimbuf
{ "time_t" "modtime" } ; { "time_t" "modtime" } ;
FUNCTION: int utime ( char* path, utimebuf* buf ) ; FUNCTION: int utime ( char* path, utimebuf* buf ) ;
FUNCTION: int err_no ( ) ;
FUNCTION: char* strerror ( int errno ) ;

15
extra/unix/system-call/system-call.factor Normal file
View File

@ -0,0 +1,15 @@
USING: kernel continuations sequences math accessors inference macros
fry arrays.lib unix.ffi ;
IN: unix.system-call
ERROR: unix-system-call-error word args message ;
MACRO: unix-system-call ( quot -- )
[ ] [ infer in>> ] [ first ] tri
'[
[ @ dup 0 < [ dup throw ] [ ] if ]
[ drop , narray , swap err_no strerror unix-system-call-error ]
recover
] ;

40
extra/unix/unix.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc structs USING: alien alien.c-types alien.syntax kernel libc structs
math namespaces system combinators vocabs.loader unix.ffi unix.types math namespaces system combinators vocabs.loader qualified
qualified ; unix.ffi unix.types unix.system-call ;
QUALIFIED: unix.ffi QUALIFIED: unix.ffi
@ -27,9 +27,27 @@ TYPEDEF: ulong size_t
: ESRCH 3 ; inline : ESRCH 3 ; inline
: EEXIST 17 ; inline : EEXIST 17 ; inline
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
C-STRUCT: passwd
{ "char*" "pw_name" }
{ "char*" "pw_passwd" }
{ "uid_t" "pw_uid" }
{ "gid_t" "pw_gid" }
{ "time_t" "pw_change" }
{ "char*" "pw_class" }
{ "char*" "pw_gecos" }
{ "char*" "pw_dir" }
{ "char*" "pw_shell" }
{ "time_t" "pw_expire" }
{ "int" "pw_fields" } ;
! ! ! Unix functions ! ! ! Unix functions
LIBRARY: factor LIBRARY: factor
FUNCTION: int err_no ( ) ;
FUNCTION: void clear_err_no ( ) ; FUNCTION: void clear_err_no ( ) ;
LIBRARY: libc LIBRARY: libc
@ -64,6 +82,9 @@ FUNCTION: int getdtablesize ;
FUNCTION: gid_t getegid ; FUNCTION: gid_t getegid ;
FUNCTION: uid_t geteuid ; FUNCTION: uid_t geteuid ;
FUNCTION: gid_t getgid ; FUNCTION: gid_t getgid ;
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: uid_t getuid ; FUNCTION: uid_t getuid ;
@ -78,19 +99,10 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ; FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: char* strerror ( int errno ) ;
ERROR: open-error path flags prot message ; : open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ;
: open ( path flags prot -- int ) : utime ( path buf -- ) [ unix.ffi:utime ] unix-system-call drop ;
3dup unix.ffi:open
dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ;
ERROR: utime-error path message ;
: utime ( path buf -- )
dupd unix.ffi:utime
0 = [ drop ] [ err_no strerror utime-error ] if ;
FUNCTION: int pclose ( void* file ) ; FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ; FUNCTION: int pipe ( int* filedes ) ;

43
vm/data_gc.c
View File

@ -7,6 +7,8 @@
#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n" #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 END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
/* #define GC_DEBUG */
#ifdef GC_DEBUG #ifdef GC_DEBUG
#define GC_PRINT printf #define GC_PRINT printf
#else #else
@ -23,7 +25,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
void init_card_decks(void) 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); allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS); cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
decks_offset = (CELL)data_heap->decks - (start >> DECK_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); 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;
@ -59,23 +61,25 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
return NULL; /* can't happen */ return NULL; /* can't happen */
} }
total_size += DECK_SIZE;
data_heap->segment = alloc_segment(total_size); data_heap->segment = alloc_segment(total_size);
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
data_heap->semispaces = 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 = safe_malloc(cards_size);
data_heap->allot_markers_end = data_heap->allot_markers + cards_size; data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
data_heap->cards = safe_malloc(cards_size); data_heap->cards = safe_malloc(cards_size);
data_heap->cards_end = data_heap->cards + 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 = safe_malloc(decks_size);
data_heap->decks_end = data_heap->decks + 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->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data_heap->semispaces[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); 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); critical_error("Bug in alloc_data_heap",alloter);
return data_heap; return data_heap;
@ -119,8 +123,6 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
free(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) void clear_cards(CELL from, CELL to)
{ {
/* NOTE: reverse order due to heap layout. */ /* 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) void clear_decks(CELL from, CELL to)
{ {
/* NOTE: reverse order due to heap layout. */ /* NOTE: reverse order due to heap layout. */
F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start); F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end); F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
F_CARD *ptr; F_DECK *ptr;
for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0; 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 *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 *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
F_CARD *ptr; 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_) void set_data_heap(F_DATA_HEAP *data_heap_)
@ -163,6 +165,10 @@ void gc_reset(void)
int i; int i;
for(i = 0; i < MAX_GEN_COUNT; i++) for(i = 0; i < MAX_GEN_COUNT; i++)
memset(&gc_stats[i],0,sizeof(F_GC_STATS)); 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, void init_data_heap(CELL gens,
@ -182,10 +188,6 @@ void init_data_heap(CELL gens,
secure_gc = secure_gc_; secure_gc = secure_gc_;
gc_reset(); gc_reset();
cards_scanned = 0;
decks_scanned = 0;
code_heap_scans = 0;
} }
/* Size of the object pointed to by a tagged pointer */ /* 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); 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_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);

28
vm/data_gc.h
View File

@ -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_NURSERY 0x80
#define CARD_POINTS_TO_AGING 0x40 #define CARD_POINTS_TO_AGING 0x40
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) #define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
#define CARD_BASE_MASK 0x3f
typedef u8 F_CARD; typedef u8 F_CARD;
/* A card is 64 bytes. 6 bits is sufficient to represent every #define CARD_BITS 8
offset within the card */ #define CARD_SIZE (1<<CARD_BITS)
#define CARD_SIZE 64
#define CARD_BITS 6
#define ADDR_CARD_MASK (CARD_SIZE-1) #define ADDR_CARD_MASK (CARD_SIZE-1)
DLLEXPORT CELL cards_offset; DLLEXPORT CELL cards_offset;
DLLEXPORT CELL allot_markers_offset;
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset) #define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS) #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
/* A deck is 4 kilobytes or 64 cards. */
typedef u8 F_DECK; typedef u8 F_DECK;
#define DECK_SIZE (4 * 1024) #define DECK_BITS (CARD_BITS + 10)
#define DECK_BITS 12 #define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1) #define ADDR_DECK_MASK (DECK_SIZE-1)
DLLEXPORT CELL decks_offset; DLLEXPORT CELL decks_offset;
@ -100,12 +95,14 @@ DLLEXPORT CELL decks_offset;
#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset) #define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers)) #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); void init_card_decks(void);
/* this is an inefficient write barrier. compiled definitions use a more /* the write barrier must be called any time we are potentially storing a
efficient one hand-coded in assembly. the write barrier must be called pointer from an older generation to a younger one */
any time we are potentially storing a pointer from an older generation
to a younger one */
INLINE void write_barrier(CELL address) INLINE void write_barrier(CELL address)
{ {
*ADDR_TO_CARD(address) = CARD_MARK_MASK; *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) INLINE void allot_barrier(CELL address)
{ {
F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
F_CARD b = *ptr; if(*ptr == INVALID_ALLOT_MARKER)
F_CARD a = (address & ADDR_CARD_MASK); *ptr = (address & ADDR_CARD_MASK);
*ptr = (b < a ? b : a);
} }
void clear_cards(CELL from, CELL to); void clear_cards(CELL from, CELL to);

6
vm/run.h
View File

@ -103,11 +103,11 @@ INLINE void bput(CELL where, CELL what)
INLINE CELL align(CELL a, CELL b) INLINE CELL align(CELL a, CELL b)
{ {
return (a + b) & ~b; return (a + (b-1)) & ~(b-1);
} }
#define align8(a) align(a,7) #define align8(a) align(a,8)
#define align_page(a) align(a,getpagesize() - 1) #define align_page(a) align(a,getpagesize())
/* Canonical T object. It's just a word */ /* Canonical T object. It's just a word */
CELL T; CELL T;