Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: extra/delegate/protocols/protocols.factordb4
Daniel Ehrenberg
commit
46b4167a24
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -51,6 +51,8 @@ call
|
|||
! After we execute bootstrap/layouts
|
||||
num-types get f <array> builtins set
|
||||
|
||||
bootstrapping? on
|
||||
|
||||
! Create some empty vocabs where the below primitives and
|
||||
! classes will go
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <string-writer> ;
|
||||
|
||||
M: growable stream-readln ( stream -- str )
|
||||
"\r\n" over stream-read-until handle-readln ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ IN: builder.report
|
|||
"Build directory: " write build-dir print
|
||||
"git id: " write "git-id" eval-file print nl
|
||||
|
||||
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
|
||||
status-boot get f = [ "boot-log" cat "Boot error" throw ] when
|
||||
status-vm get f = [ "compile-log" cat "vm compile 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
|
||||
|
||||
"Boot time: " write "boot-time" eval-file milli-seconds>time print
|
||||
|
|
|
|||
|
|
@ -16,12 +16,12 @@ PROTOCOL: assoc-protocol
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
! Test duplex stream close behavior
|
||||
|
|
@ -38,3 +39,8 @@ M: unclosable-stream dispose
|
|||
[ dup dispose ] [ 2drop ] recover
|
||||
] keep closing-stream-closed?
|
||||
] unit-test
|
||||
|
||||
[ "Hey" ] [
|
||||
"Hey\nThere" <string-reader> <string-writer> <duplex-stream>
|
||||
stream-readln
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
continuations system libc qualified namespaces io.timeouts
|
||||
io.encodings.utf8 accessors ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien.c-types kernel math math.bitfields namespaces
|
||||
locals accessors combinators threads vectors hashtables
|
||||
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.monitors ;
|
||||
IN: io.unix.kqueue
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ namespaces threads sequences byte-arrays io.nonblocking
|
|||
io.binary io.unix.backend io.streams.duplex io.sockets.impl
|
||||
io.backend io.files io.files.private io.encodings.utf8
|
||||
math.parser continuations libc combinators system accessors
|
||||
qualified unix ;
|
||||
qualified unix.ffi unix ;
|
||||
|
||||
EXCLUDE: io => read write close ;
|
||||
EXCLUDE: io.sockets => accept ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -127,7 +127,9 @@ C: <segment> 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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -3,21 +3,9 @@ math.functions math.ranges namespaces random sequences
|
|||
hashtables sets ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: n
|
||||
SYMBOL: r
|
||||
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 ;
|
||||
: >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 ;
|
||||
|
||||
|
|
@ -28,34 +16,30 @@ TUPLE: positive-even-expected n ;
|
|||
#! factor an integer into s * 2^r
|
||||
0 swap (factor-2s) ;
|
||||
|
||||
:: (miller-rabin) ( n prime?! -- ? )
|
||||
n 1- factor-2s s set r set
|
||||
trials get [
|
||||
n 1- [1,b] random a set
|
||||
a get s get n ^mod 1 = [
|
||||
0 count set
|
||||
r get [
|
||||
2^ s get * a get swap n ^mod n - -1 = [
|
||||
count [ 1+ ] change
|
||||
r get +
|
||||
] when
|
||||
] each
|
||||
count get zero? [
|
||||
f prime?!
|
||||
trials get +
|
||||
] when
|
||||
] unless
|
||||
drop
|
||||
] each prime? ;
|
||||
|
||||
TUPLE: miller-rabin-bounds ;
|
||||
:: (miller-rabin) ( n trials -- ? )
|
||||
[let | r [ n 1- factor-2s drop ]
|
||||
s [ n 1- factor-2s nip ]
|
||||
prime?! [ t ]
|
||||
a! [ 0 ]
|
||||
count! [ 0 ] |
|
||||
trials [
|
||||
n 1- [1,b] random a!
|
||||
a s n ^mod 1 = [
|
||||
0 count!
|
||||
r [
|
||||
2^ s * a swap n ^mod n - -1 =
|
||||
[ count 1+ count! r + ] when
|
||||
] each
|
||||
count zero? [ f prime?! trials + ] when
|
||||
] unless drop
|
||||
] each prime? ] ;
|
||||
|
||||
: miller-rabin* ( n numtrials -- ? )
|
||||
over {
|
||||
{ [ dup 1 <= ] [ 3drop f ] }
|
||||
{ [ dup 2 = ] [ 3drop t ] }
|
||||
{ [ dup even? ] [ 3drop f ] }
|
||||
[ [ drop trials set t (miller-rabin) ] with-scope ]
|
||||
[ [ drop (miller-rabin) ] with-scope ]
|
||||
} cond ;
|
||||
|
||||
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
|
||||
|
|
@ -66,7 +50,11 @@ TUPLE: miller-rabin-bounds ;
|
|||
: random-prime ( numbits -- p )
|
||||
random-bits next-prime ;
|
||||
|
||||
ERROR: no-relative-prime n ;
|
||||
|
||||
: (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 ;
|
||||
|
||||
: find-relative-prime* ( n guess -- p )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,99 +1,92 @@
|
|||
USING: combinators io io.files io.streams.string kernel math
|
||||
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
|
||||
|
||||
: zero-checksum 256 ;
|
||||
: zero-checksum 256 ; inline
|
||||
: block-size 512 ; inline
|
||||
|
||||
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
||||
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 )
|
||||
[ "\0 " member? ] trim ;
|
||||
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
|
||||
|
||||
: read-tar-header ( -- obj )
|
||||
<tar-header>
|
||||
100 read-c-string* over set-tar-header-name
|
||||
8 read-c-string* tar-trim oct> over set-tar-header-mode
|
||||
8 read-c-string* tar-trim oct> over set-tar-header-uid
|
||||
8 read-c-string* tar-trim oct> over set-tar-header-gid
|
||||
12 read-c-string* tar-trim oct> over set-tar-header-size
|
||||
12 read-c-string* tar-trim oct> over set-tar-header-mtime
|
||||
8 read-c-string* tar-trim oct> over set-tar-header-checksum
|
||||
read1 over set-tar-header-typeflag
|
||||
100 read-c-string* over set-tar-header-linkname
|
||||
6 read over set-tar-header-magic
|
||||
2 read over set-tar-header-version
|
||||
32 read-c-string* over set-tar-header-uname
|
||||
32 read-c-string* over set-tar-header-gname
|
||||
8 read tar-trim oct> over set-tar-header-devmajor
|
||||
8 read tar-trim oct> over set-tar-header-devminor
|
||||
155 read-c-string* over set-tar-header-prefix ;
|
||||
\ tar-header new
|
||||
100 read-c-string* >>name
|
||||
8 read-c-string* tar-trim oct> >>mode
|
||||
8 read-c-string* tar-trim oct> >>uid
|
||||
8 read-c-string* tar-trim oct> >>gid
|
||||
12 read-c-string* tar-trim oct> >>size
|
||||
12 read-c-string* tar-trim oct> >>mtime
|
||||
8 read-c-string* tar-trim oct> >>checksum
|
||||
read1 >>typeflag
|
||||
100 read-c-string* >>linkname
|
||||
6 read >>magic
|
||||
2 read >>version
|
||||
32 read-c-string* >>uname
|
||||
32 read-c-string* >>gname
|
||||
8 read tar-trim oct> >>devmajor
|
||||
8 read tar-trim oct> >>devminor
|
||||
155 read-c-string* >>prefix ;
|
||||
|
||||
: header-checksum ( seq -- x )
|
||||
148 cut-slice 8 tail-slice
|
||||
[ sum ] bi@ + 256 + ;
|
||||
|
||||
TUPLE: checksum-error ;
|
||||
TUPLE: malformed-block-error ;
|
||||
|
||||
SYMBOL: base-dir
|
||||
SYMBOL: out-stream
|
||||
SYMBOL: filename
|
||||
|
||||
: (read-data-blocks) ( tar-header -- )
|
||||
512 read [
|
||||
over tar-header-size dup 512 <= [
|
||||
head-slice
|
||||
>string write
|
||||
drop
|
||||
: read-data-blocks ( tar-header -- )
|
||||
dup size>> 0 > [
|
||||
block-size read [
|
||||
over size>> dup block-size <= [
|
||||
head-slice >byte-array write drop
|
||||
] [
|
||||
drop write
|
||||
[ block-size - ] change-size
|
||||
read-data-blocks
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
>string write
|
||||
dup tar-header-size 512 - over set-tar-header-size
|
||||
(read-data-blocks)
|
||||
] if
|
||||
] if*
|
||||
] [
|
||||
drop
|
||||
] if* ;
|
||||
|
||||
: read-data-blocks ( tar-header out -- )
|
||||
[ (read-data-blocks) ] with-output-stream* ;
|
||||
] if ;
|
||||
|
||||
: parse-tar-header ( seq -- obj )
|
||||
[ header-checksum ] keep over zero-checksum = [
|
||||
2drop
|
||||
\ tar-header new
|
||||
0 over set-tar-header-size
|
||||
0 over set-tar-header-checksum
|
||||
0 >>size
|
||||
0 >>checksum
|
||||
] [
|
||||
[ read-tar-header ] with-string-reader
|
||||
[ tar-header-checksum = [
|
||||
\ checksum-error new throw
|
||||
] unless
|
||||
] keep
|
||||
[ checksum>> = [ checksum-error ] unless ] keep
|
||||
] if ;
|
||||
|
||||
ERROR: unknown-typeflag ch ;
|
||||
M: unknown-typeflag summary ( obj -- str )
|
||||
ch>> 1string
|
||||
"Unknown typeflag: " prepend ;
|
||||
ch>> 1string "Unknown typeflag: " prepend ;
|
||||
|
||||
: tar-append-path ( path -- newpath )
|
||||
: tar-prepend-path ( path -- newpath )
|
||||
base-dir get prepend-path ;
|
||||
|
||||
: read/write-blocks ( tar-header path -- )
|
||||
binary [ read-data-blocks ] with-file-writer ;
|
||||
|
||||
! Normal file
|
||||
: typeflag-0
|
||||
name>> tar-append-path binary <file-writer>
|
||||
[ read-data-blocks ] keep dispose ;
|
||||
: typeflag-0 ( header -- )
|
||||
dup name>> tar-prepend-path read/write-blocks ;
|
||||
|
||||
! Hard link
|
||||
: typeflag-1 ( header -- ) unknown-typeflag ;
|
||||
|
||||
! Symlink
|
||||
: typeflag-2 ( header -- ) unknown-typeflag ;
|
||||
: typeflag-2 ( header -- )
|
||||
[ name>> ] [ linkname>> ] bi
|
||||
[ make-link ] 2curry ignore-errors ;
|
||||
|
||||
! character special
|
||||
: typeflag-3 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Directory
|
||||
: typeflag-5 ( header -- )
|
||||
tar-header-name tar-append-path make-directories ;
|
||||
name>> tar-prepend-path make-directories ;
|
||||
|
||||
! FIFO
|
||||
: typeflag-6 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
: typeflag-9 ( header -- ) unknown-typeflag ;
|
||||
|
||||
! Global POSIX header
|
||||
: typeflag-g ( header -- ) unknown-typeflag ;
|
||||
: typeflag-g ( header -- ) typeflag-0 ;
|
||||
|
||||
! Extended POSIX header
|
||||
: typeflag-x ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Long file name
|
||||
: typeflag-L ( header -- )
|
||||
<string-writer> [ read-data-blocks ] keep
|
||||
>string [ zero? ] right-trim filename set
|
||||
global [ "long filename: " write filename get . flush ] bind
|
||||
filename get tar-append-path make-directories ;
|
||||
drop ;
|
||||
! <string-writer> [ read-data-blocks ] keep
|
||||
! >string [ zero? ] right-trim filename set
|
||||
! filename get tar-prepend-path make-directories ;
|
||||
|
||||
! Multi volume continuation entry
|
||||
: typeflag-M ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
: typeflag-X ( header -- ) unknown-typeflag ;
|
||||
|
||||
: (parse-tar) ( -- )
|
||||
512 read
|
||||
global [ dup hexdump. flush ] bind
|
||||
[
|
||||
block-size read dup length 512 = [
|
||||
parse-tar-header
|
||||
! global [ dup tar-header-name [ print flush ] when* ] bind
|
||||
dup tar-header-typeflag
|
||||
dup typeflag>>
|
||||
{
|
||||
{ 0 [ typeflag-0 ] }
|
||||
{ CHAR: 0 [ typeflag-0 ] }
|
||||
{ CHAR: 1 [ typeflag-1 ] }
|
||||
! { CHAR: 1 [ typeflag-1 ] }
|
||||
{ CHAR: 2 [ typeflag-2 ] }
|
||||
{ CHAR: 3 [ typeflag-3 ] }
|
||||
{ CHAR: 4 [ typeflag-4 ] }
|
||||
! { CHAR: 3 [ typeflag-3 ] }
|
||||
! { CHAR: 4 [ typeflag-4 ] }
|
||||
{ CHAR: 5 [ typeflag-5 ] }
|
||||
{ CHAR: 6 [ typeflag-6 ] }
|
||||
{ CHAR: 7 [ typeflag-7 ] }
|
||||
! { CHAR: 6 [ typeflag-6 ] }
|
||||
! { CHAR: 7 [ typeflag-7 ] }
|
||||
{ CHAR: g [ typeflag-g ] }
|
||||
{ CHAR: x [ typeflag-x ] }
|
||||
{ CHAR: A [ typeflag-A ] }
|
||||
{ CHAR: D [ typeflag-D ] }
|
||||
{ CHAR: E [ typeflag-E ] }
|
||||
{ CHAR: I [ typeflag-I ] }
|
||||
{ CHAR: K [ typeflag-K ] }
|
||||
{ CHAR: L [ typeflag-L ] }
|
||||
{ CHAR: M [ typeflag-M ] }
|
||||
{ CHAR: N [ typeflag-N ] }
|
||||
{ CHAR: S [ typeflag-S ] }
|
||||
{ CHAR: V [ typeflag-V ] }
|
||||
{ CHAR: X [ typeflag-X ] }
|
||||
[ unknown-typeflag ]
|
||||
} case
|
||||
! dup tar-header-size zero? [
|
||||
! out-stream get [ dispose ] when
|
||||
! out-stream off
|
||||
! 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* ;
|
||||
! { CHAR: x [ typeflag-x ] }
|
||||
! { CHAR: A [ typeflag-A ] }
|
||||
! { CHAR: D [ typeflag-D ] }
|
||||
! { CHAR: E [ typeflag-E ] }
|
||||
! { CHAR: I [ typeflag-I ] }
|
||||
! { CHAR: K [ typeflag-K ] }
|
||||
! { CHAR: L [ typeflag-L ] }
|
||||
! { CHAR: M [ typeflag-M ] }
|
||||
! { CHAR: N [ typeflag-N ] }
|
||||
! { CHAR: S [ typeflag-S ] }
|
||||
! { CHAR: V [ typeflag-V ] }
|
||||
! { CHAR: X [ typeflag-X ] }
|
||||
{ f [ drop ] }
|
||||
} case (parse-tar)
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: parse-tar ( path -- obj )
|
||||
binary [
|
||||
"resource:tar-test" base-dir set
|
||||
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
|
||||
global [ "Expanding to: " write base-dir get . flush ] bind
|
||||
(parse-tar)
|
||||
] with-file-writer ;
|
||||
: parse-tar ( path -- )
|
||||
normalize-path dup parent-directory base-dir [
|
||||
binary [ (parse-tar) ] with-file-reader
|
||||
] with-variable ;
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -9,4 +9,7 @@ C-STRUCT: utimbuf
|
|||
{ "time_t" "actime" }
|
||||
{ "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 ) ;
|
||||
|
|
@ -30,4 +30,4 @@ FUNCTION: int lstat ( char* pathname, stat* buf ) ;
|
|||
|
||||
: stat-st_atim stat-st_atimespec ;
|
||||
: stat-st_mtim stat-st_mtimespec ;
|
||||
: stat-st_ctim stat-st_ctimespec ;
|
||||
: stat-st_ctim stat-st_ctimespec ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] ;
|
||||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: alien alien.c-types alien.syntax kernel libc structs
|
||||
math namespaces system combinators vocabs.loader unix.ffi unix.types
|
||||
qualified ;
|
||||
math namespaces system combinators vocabs.loader qualified
|
||||
unix.ffi unix.types unix.system-call ;
|
||||
|
||||
QUALIFIED: unix.ffi
|
||||
|
||||
|
|
@ -27,9 +27,27 @@ TYPEDEF: ulong size_t
|
|||
: ESRCH 3 ; 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
|
||||
LIBRARY: factor
|
||||
FUNCTION: int err_no ( ) ;
|
||||
FUNCTION: void clear_err_no ( ) ;
|
||||
|
||||
LIBRARY: libc
|
||||
|
|
@ -64,6 +82,9 @@ FUNCTION: int getdtablesize ;
|
|||
FUNCTION: gid_t getegid ;
|
||||
FUNCTION: uid_t geteuid ;
|
||||
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 gethostname ( char* name, int len ) ;
|
||||
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: uint ntohl ( uint 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 )
|
||||
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 ;
|
||||
: utime ( path buf -- ) [ unix.ffi:utime ] unix-system-call drop ;
|
||||
|
||||
FUNCTION: int pclose ( void* file ) ;
|
||||
FUNCTION: int pipe ( int* filedes ) ;
|
||||
|
|
|
|||
43
vm/data_gc.c
43
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);
|
||||
|
||||
|
|
|
|||
28
vm/data_gc.h
28
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)
|
||||
#define ADDR_CARD_MASK (CARD_SIZE-1)
|
||||
|
||||
DLLEXPORT CELL cards_offset;
|
||||
DLLEXPORT CELL allot_markers_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)
|
||||
|
||||
/* A deck is 4 kilobytes or 64 cards. */
|
||||
typedef u8 F_DECK;
|
||||
|
||||
#define DECK_SIZE (4 * 1024)
|
||||
#define DECK_BITS 12
|
||||
#define DECK_BITS (CARD_BITS + 10)
|
||||
#define DECK_SIZE (1<<DECK_BITS)
|
||||
#define ADDR_DECK_MASK (DECK_SIZE-1)
|
||||
|
||||
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 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);
|
||||
|
|
|
|||
6
vm/run.h
6
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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue