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
commit 46b4167a24
39 changed files with 449 additions and 247 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

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

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

View File

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

View File

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

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

@ -0,0 +1 @@
James Cash

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

View File

@ -0,0 +1 @@
James Cash

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

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

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_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);

View File

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