Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
16ad61021f
|
|
@ -16,9 +16,10 @@ N [ F stack-effect out>> length ]
|
|||
|
||||
WHERE
|
||||
|
||||
TUPLE: F-destructor alien disposed ;
|
||||
TUPLE: F-destructor < disposable alien ;
|
||||
|
||||
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
|
||||
: <F-destructor> ( alien -- destructor )
|
||||
F-destructor new-disposable swap >>alien ; inline
|
||||
|
||||
M: F-destructor dispose* alien>> F N ndrop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ IN: bootstrap.tools
|
|||
"tools.crossref"
|
||||
"tools.errors"
|
||||
"tools.deploy"
|
||||
"tools.destructors"
|
||||
"tools.disassembler"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@
|
|||
USING: kernel assocs math accessors destructors fry sequences ;
|
||||
IN: cache
|
||||
|
||||
TUPLE: cache-assoc assoc max-age disposed ;
|
||||
TUPLE: cache-assoc < disposable assoc max-age ;
|
||||
|
||||
: <cache-assoc> ( -- cache )
|
||||
H{ } clone 10 f cache-assoc boa ;
|
||||
cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: specialized-arrays.int arrays kernel math namespaces make
|
||||
USING: arrays kernel math namespaces make
|
||||
cocoa cocoa.messages cocoa.classes core-graphics
|
||||
core-graphics.types sequences continuations accessors ;
|
||||
IN: cocoa.views
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs math math.parser memoize
|
||||
io.encodings.ascii io.files lexer parser
|
||||
colors sequences splitting combinators.smart ascii ;
|
||||
USING: kernel assocs math math.parser memoize io.encodings.utf8
|
||||
io.files lexer parser colors sequences splitting
|
||||
combinators.smart ascii ;
|
||||
IN: colors.constants
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -19,7 +19,7 @@ IN: colors.constants
|
|||
[ parse-color ] H{ } map>assoc ;
|
||||
|
||||
MEMO: rgb.txt ( -- assoc )
|
||||
"resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
|
||||
"resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -6,12 +6,12 @@ arrays assocs init system concurrency.conditions accessors
|
|||
debugger debugger.threads locals fry ;
|
||||
IN: concurrency.mailboxes
|
||||
|
||||
TUPLE: mailbox threads data disposed ;
|
||||
TUPLE: mailbox < disposable threads data ;
|
||||
|
||||
M: mailbox dispose* threads>> notify-all ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
<dlist> <dlist> f mailbox boa ;
|
||||
mailbox new-disposable <dlist> >>threads <dlist> >>data ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
data>> deque-empty? ;
|
||||
|
|
|
|||
|
|
@ -181,15 +181,15 @@ SYMBOL: event-stream-callbacks
|
|||
}
|
||||
"cdecl" [ (master-event-source-callback) ] alien-callback ;
|
||||
|
||||
TUPLE: event-stream info handle disposed ;
|
||||
TUPLE: event-stream < disposable info handle ;
|
||||
|
||||
: <event-stream> ( quot paths latency flags -- event-stream )
|
||||
[
|
||||
add-event-source-callback dup
|
||||
[ master-event-source-callback ] dip
|
||||
add-event-source-callback
|
||||
[ master-event-source-callback ] keep
|
||||
] 3dip <FSEventStream>
|
||||
dup enable-event-stream
|
||||
f event-stream boa ;
|
||||
event-stream new-disposable swap >>handle swap >>info ;
|
||||
|
||||
M: event-stream dispose*
|
||||
{
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ ERROR: not-a-string object ;
|
|||
CTLineCreateWithAttributedString
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: line line metrics image loc dim disposed ;
|
||||
TUPLE: line < disposable line metrics image loc dim ;
|
||||
|
||||
: typographic-bounds ( line -- width ascent descent leading )
|
||||
0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
|
||||
|
|
@ -109,6 +109,8 @@ TUPLE: line line metrics image loc dim disposed ;
|
|||
|
||||
:: <line> ( font string -- line )
|
||||
[
|
||||
line new-disposable
|
||||
|
||||
[let* | open-font [ font cache-font ]
|
||||
line [ string open-font font foreground>> <CTLine> |CFRelease ]
|
||||
|
||||
|
|
@ -120,7 +122,11 @@ TUPLE: line line metrics image loc dim disposed ;
|
|||
ext [ (loc) (dim) [ + ceiling ] 2map ]
|
||||
dim [ ext loc [ - >integer ] 2map ]
|
||||
metrics [ open-font line compute-line-metrics ] |
|
||||
line metrics
|
||||
|
||||
line >>line
|
||||
|
||||
metrics >>metrics
|
||||
|
||||
dim [
|
||||
{
|
||||
[ font dim fill-background ]
|
||||
|
|
@ -128,11 +134,12 @@ TUPLE: line line metrics image loc dim disposed ;
|
|||
[ loc set-text-position ]
|
||||
[ [ line ] dip CTLineDraw ]
|
||||
} cleave
|
||||
] make-bitmap-image
|
||||
metrics loc dim line-loc
|
||||
metrics metrics>dim
|
||||
] make-bitmap-image >>image
|
||||
|
||||
metrics loc dim line-loc >>loc
|
||||
|
||||
metrics metrics>dim >>dim
|
||||
]
|
||||
f line boa
|
||||
] with-destructors ;
|
||||
|
||||
M: line dispose* line>> CFRelease ;
|
||||
|
|
|
|||
|
|
@ -287,9 +287,9 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
|
|||
{ $heading "Debugging" }
|
||||
{ $subsection "prettyprint" }
|
||||
{ $subsection "inspector" }
|
||||
{ $subsection "tools.inference" }
|
||||
{ $subsection "tools.annotations" }
|
||||
{ $subsection "tools.deprecation" }
|
||||
{ $subsection "tools.inference" }
|
||||
{ $heading "Browsing" }
|
||||
{ $subsection "see" }
|
||||
{ $subsection "tools.crossref" }
|
||||
|
|
@ -299,6 +299,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
|
|||
{ $subsection "profiling" }
|
||||
{ $subsection "tools.memory" }
|
||||
{ $subsection "tools.threads" }
|
||||
{ $subsection "tools.destructors" }
|
||||
{ $subsection "tools.disassembler" }
|
||||
{ $heading "Deployment" }
|
||||
{ $subsection "tools.deploy" } ;
|
||||
|
|
|
|||
|
|
@ -4,14 +4,15 @@ USING: alien alien.c-types alien.syntax generic assocs kernel
|
|||
kernel.private math io.ports sequences strings sbufs threads
|
||||
unix vectors io.buffers io.backend io.encodings math.parser
|
||||
continuations system libc namespaces make io.timeouts
|
||||
io.encodings.utf8 destructors accessors summary combinators
|
||||
locals unix.time fry io.backend.unix.multiplexers ;
|
||||
io.encodings.utf8 destructors destructors.private accessors
|
||||
summary combinators locals unix.time fry
|
||||
io.backend.unix.multiplexers ;
|
||||
QUALIFIED: io
|
||||
IN: io.backend.unix
|
||||
|
||||
GENERIC: handle-fd ( handle -- fd )
|
||||
|
||||
TUPLE: fd fd disposed ;
|
||||
TUPLE: fd < disposable fd ;
|
||||
|
||||
: init-fd ( fd -- fd )
|
||||
[
|
||||
|
|
@ -25,14 +26,16 @@ TUPLE: fd fd disposed ;
|
|||
#! since on OS X 10.3, this operation fails from init-io
|
||||
#! when running the Factor.app (presumably because fd 0 and
|
||||
#! 1 are closed).
|
||||
f fd boa ;
|
||||
fd new-disposable swap >>fd ;
|
||||
|
||||
M: fd dispose
|
||||
dup disposed>> [ drop ] [
|
||||
[ cancel-operation ]
|
||||
[ t >>disposed drop ]
|
||||
[ fd>> close-file ]
|
||||
tri
|
||||
{
|
||||
[ cancel-operation ]
|
||||
[ t >>disposed drop ]
|
||||
[ unregister-disposable ]
|
||||
[ fd>> close-file ]
|
||||
} cleave
|
||||
] if ;
|
||||
|
||||
M: fd handle-fd dup check-disposed fd>> ;
|
||||
|
|
@ -133,7 +136,7 @@ M: unix io-multiplex ( ms/f -- )
|
|||
! pipe to non-blocking, and read from it instead of the real
|
||||
! stdin. Very crufty, but it will suffice until we get native
|
||||
! threading support at the language level.
|
||||
TUPLE: stdin control size data disposed ;
|
||||
TUPLE: stdin < disposable control size data ;
|
||||
|
||||
M: stdin dispose*
|
||||
[
|
||||
|
|
@ -168,7 +171,7 @@ M: stdin refill
|
|||
: data-read-fd ( -- fd ) &: stdin_read *uint ;
|
||||
|
||||
: <stdin> ( -- stdin )
|
||||
stdin new
|
||||
stdin new-disposable
|
||||
control-write-fd <fd> <output-port> >>control
|
||||
size-read-fd <fd> init-fd <input-port> >>size
|
||||
data-read-fd <fd> >>data ;
|
||||
|
|
|
|||
|
|
@ -7,33 +7,21 @@ windows.kernel32 windows.shell32 windows.types windows.winsock
|
|||
splitting continuations math.bitwise accessors init sets assocs ;
|
||||
IN: io.backend.windows
|
||||
|
||||
: win32-handles ( -- assoc )
|
||||
\ win32-handles [ H{ } clone ] initialize-alien ;
|
||||
|
||||
TUPLE: win32-handle < identity-tuple handle disposed ;
|
||||
|
||||
M: win32-handle hashcode* handle>> hashcode* ;
|
||||
TUPLE: win32-handle < disposable handle ;
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
[ handle>> HANDLE_FLAG_INHERIT ] dip
|
||||
>BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||
|
||||
: new-win32-handle ( handle class -- win32-handle )
|
||||
new swap >>handle
|
||||
dup f set-inherit
|
||||
dup win32-handles conjoin ;
|
||||
new-disposable swap >>handle
|
||||
dup f set-inherit ;
|
||||
|
||||
: <win32-handle> ( handle -- win32-handle )
|
||||
win32-handle new-win32-handle ;
|
||||
|
||||
ERROR: disposing-twice ;
|
||||
|
||||
: unregister-handle ( handle -- )
|
||||
win32-handles delete-at*
|
||||
[ t >>disposed drop ] [ disposing-twice ] if ;
|
||||
|
||||
M: win32-handle dispose* ( handle -- )
|
||||
[ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ;
|
||||
handle>> CloseHandle win32-error=0/f ;
|
||||
|
||||
TUPLE: win32-file < win32-handle ptr ;
|
||||
|
||||
|
|
@ -54,7 +42,7 @@ HOOK: add-completion io-backend ( port -- )
|
|||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
|
||||
: share-mode ( -- fixnum )
|
||||
: share-mode ( -- n )
|
||||
{
|
||||
FILE_SHARE_READ
|
||||
FILE_SHARE_WRITE
|
||||
|
|
|
|||
|
|
@ -6,30 +6,29 @@ accessors vocabs.loader combinators alien.c-types
|
|||
math ;
|
||||
IN: io.mmap
|
||||
|
||||
TUPLE: mapped-file address handle length disposed ;
|
||||
TUPLE: mapped-file < disposable address handle length ;
|
||||
|
||||
HOOK: (mapped-file-reader) os ( path length -- address handle )
|
||||
HOOK: (mapped-file-r/w) os ( path length -- address handle )
|
||||
|
||||
ERROR: bad-mmap-size path size ;
|
||||
ERROR: bad-mmap-size n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: prepare-mapped-file ( path -- path' n )
|
||||
[ normalize-path ] [ file-info size>> ] bi
|
||||
dup 0 <= [ bad-mmap-size ] when ;
|
||||
: prepare-mapped-file ( path quot -- mapped-file path' length )
|
||||
[
|
||||
[ normalize-path ] [ file-info size>> ] bi
|
||||
[ dup 0 <= [ bad-mmap-size ] [ 2drop ] if ]
|
||||
[ nip mapped-file new-disposable swap >>length ]
|
||||
] dip 2tri [ >>address ] [ >>handle ] bi* ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <mapped-file-reader> ( path -- mmap )
|
||||
prepare-mapped-file
|
||||
[ (mapped-file-reader) ] keep
|
||||
f mapped-file boa ;
|
||||
[ (mapped-file-reader) ] prepare-mapped-file ;
|
||||
|
||||
: <mapped-file> ( path -- mmap )
|
||||
prepare-mapped-file
|
||||
[ (mapped-file-r/w) ] keep
|
||||
f mapped-file boa ;
|
||||
[ (mapped-file-r/w) ] prepare-mapped-file ;
|
||||
|
||||
HOOK: close-mapped-file io-backend ( mmap -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ SYMBOL: watches
|
|||
|
||||
SYMBOL: inotify
|
||||
|
||||
TUPLE: linux-monitor < monitor wd inotify watches disposed ;
|
||||
TUPLE: linux-monitor < monitor wd inotify watches ;
|
||||
|
||||
: <linux-monitor> ( wd path mailbox -- monitor )
|
||||
linux-monitor new-monitor
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ M: object dispose-monitors ;
|
|||
[ dispose-monitors ] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
TUPLE: monitor < identity-tuple path queue timeout ;
|
||||
TUPLE: monitor < disposable path queue timeout ;
|
||||
|
||||
M: monitor hashcode* path>> hashcode* ;
|
||||
|
||||
|
|
@ -29,7 +29,7 @@ M: monitor timeout timeout>> ;
|
|||
M: monitor set-timeout (>>timeout) ;
|
||||
|
||||
: new-monitor ( path mailbox class -- monitor )
|
||||
new
|
||||
new-disposable
|
||||
swap >>queue
|
||||
swap >>path ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: io.monitors.recursive
|
|||
|
||||
! Simulate recursive monitors on platforms that don't have them
|
||||
|
||||
TUPLE: recursive-monitor < monitor children thread ready disposed ;
|
||||
TUPLE: recursive-monitor < monitor children thread ready ;
|
||||
|
||||
: notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,14 +10,14 @@ IN: io.ports
|
|||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
TUPLE: port handle timeout disposed ;
|
||||
TUPLE: port < disposable handle timeout ;
|
||||
|
||||
M: port timeout timeout>> ;
|
||||
|
||||
M: port set-timeout (>>timeout) ;
|
||||
|
||||
: <port> ( handle class -- port )
|
||||
new swap >>handle ; inline
|
||||
new-disposable swap >>handle ; inline
|
||||
|
||||
TUPLE: buffered-port < port { buffer buffer } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -78,9 +78,9 @@ TUPLE: openssl-context < secure-context aliens sessions ;
|
|||
SSL_CTX_set_verify_depth
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: bio handle disposed ;
|
||||
TUPLE: bio < disposable handle ;
|
||||
|
||||
: <bio> ( handle -- bio ) f bio boa ;
|
||||
: <bio> ( handle -- bio ) bio new-disposable swap >>handle ;
|
||||
|
||||
M: bio dispose* handle>> BIO_free ssl-error ;
|
||||
|
||||
|
|
@ -94,9 +94,9 @@ M: bio dispose* handle>> BIO_free ssl-error ;
|
|||
SSL_CTX_set_tmp_dh ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: rsa handle disposed ;
|
||||
TUPLE: rsa < disposable handle ;
|
||||
|
||||
: <rsa> ( handle -- rsa ) f rsa boa ;
|
||||
: <rsa> ( handle -- rsa ) rsa new-disposable swap >>handle ;
|
||||
|
||||
M: rsa dispose* handle>> RSA_free ;
|
||||
|
||||
|
|
@ -109,7 +109,7 @@ M: rsa dispose* handle>> RSA_free ;
|
|||
SSL_CTX_set_tmp_rsa ssl-error ;
|
||||
|
||||
: <openssl-context> ( config ctx -- context )
|
||||
openssl-context new
|
||||
openssl-context new-disposable
|
||||
swap >>handle
|
||||
swap >>config
|
||||
V{ } clone >>aliens
|
||||
|
|
@ -139,7 +139,7 @@ M: openssl-context dispose*
|
|||
[ handle>> SSL_CTX_free ]
|
||||
tri ;
|
||||
|
||||
TUPLE: ssl-handle file handle connected disposed ;
|
||||
TUPLE: ssl-handle < disposable file handle connected ;
|
||||
|
||||
SYMBOL: default-secure-context
|
||||
|
||||
|
|
@ -151,8 +151,10 @@ SYMBOL: default-secure-context
|
|||
] unless* ;
|
||||
|
||||
: <ssl-handle> ( fd -- ssl )
|
||||
current-secure-context handle>> SSL_new dup ssl-error
|
||||
f f ssl-handle boa ;
|
||||
ssl-handle new-disposable
|
||||
current-secure-context handle>> SSL_new
|
||||
dup ssl-error >>handle
|
||||
swap >>file ;
|
||||
|
||||
M: ssl-handle dispose*
|
||||
[ handle>> SSL_free ] [ file>> dispose ] bi ;
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ ephemeral-key-bits ;
|
|||
"vocab:openssl/cacert.pem" >>ca-file
|
||||
t >>verify ;
|
||||
|
||||
TUPLE: secure-context config handle disposed ;
|
||||
TUPLE: secure-context < disposable config handle ;
|
||||
|
||||
HOOK: <secure-context> secure-socket-backend ( config -- context )
|
||||
|
||||
|
|
|
|||
|
|
@ -79,6 +79,8 @@ concurrency.promises threads io.streams.string ;
|
|||
! See what happens if other end is closed
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [ "datagram3" get dispose ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> utf8 <server>
|
||||
|
|
@ -93,6 +95,8 @@ concurrency.promises threads io.streams.string ;
|
|||
|
||||
[ "hello" f ] [
|
||||
"port" get ?promise utf8 [
|
||||
1 seconds input-stream get set-timeout
|
||||
1 seconds output-stream get set-timeout
|
||||
"hi\n" write flush readln readln
|
||||
] with-client
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -268,7 +268,7 @@ DEFER: make-texture
|
|||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
|
||||
TUPLE: single-texture < disposable image dim loc texture-coords texture display-list ;
|
||||
|
||||
: adjust-texture-dim ( dim -- dim' )
|
||||
non-power-of-2-textures? get [
|
||||
|
|
@ -331,7 +331,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
|
|||
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
|
||||
|
||||
: <single-texture> ( image loc -- texture )
|
||||
single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
|
||||
single-texture new-disposable swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
|
||||
dup image>> dim>> product 0 = [
|
||||
dup texture-coords >>texture-coords
|
||||
dup image>> make-texture >>texture
|
||||
|
|
@ -347,7 +347,7 @@ M: single-texture draw-scaled-texture
|
|||
dup texture>> [ draw-textured-rect ] [ 2drop ] if
|
||||
] if ;
|
||||
|
||||
TUPLE: multi-texture grid display-list loc disposed ;
|
||||
TUPLE: multi-texture < disposable grid display-list loc ;
|
||||
|
||||
: image-locs ( image-grid -- loc-grid )
|
||||
[ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
|
||||
|
|
@ -373,11 +373,9 @@ TUPLE: multi-texture grid display-list loc disposed ;
|
|||
|
||||
: <multi-texture> ( image-grid loc -- multi-texture )
|
||||
[
|
||||
[
|
||||
<texture-grid> dup
|
||||
make-textured-grid-display-list
|
||||
] keep
|
||||
f multi-texture boa
|
||||
[ multi-texture new-disposable ] 2dip
|
||||
[ nip >>loc ] [ <texture-grid> >>grid ] 2bi
|
||||
dup grid>> make-textured-grid-display-list >>display-list
|
||||
] with-destructors ;
|
||||
|
||||
M: multi-texture draw-scaled-texture nip draw-texture ;
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ pango_layout_iter_free ( PangoLayoutIter* iter ) ;
|
|||
|
||||
DESTRUCTOR: pango_layout_iter_free
|
||||
|
||||
TUPLE: layout font string selection layout metrics ink-rect logical-rect image disposed ;
|
||||
TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
|
||||
|
||||
SYMBOL: dpi
|
||||
|
||||
|
|
@ -186,7 +186,7 @@ MEMO: missing-font-metrics ( font -- metrics )
|
|||
|
||||
: <layout> ( font string -- line )
|
||||
[
|
||||
layout new
|
||||
layout new-disposable
|
||||
swap unpack-selection
|
||||
swap >>font
|
||||
dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: words ;
|
||||
USING: kernel words ;
|
||||
IN: generic
|
||||
|
||||
: next-method-quot ( method -- quot ) "next-method-quot" word-prop ;
|
||||
: (call-next-method) ( method -- )
|
||||
dup "next-method" word-prop execute ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ vocabs sequences sequences.private words memory kernel.private
|
|||
continuations io vocabs.loader system strings sets vectors quotations
|
||||
byte-arrays sorting compiler.units definitions generic
|
||||
generic.standard generic.single tools.deploy.config combinators
|
||||
classes slots.private ;
|
||||
classes classes.builtin slots.private grouping ;
|
||||
QUALIFIED: bootstrap.stage2
|
||||
QUALIFIED: command-line
|
||||
QUALIFIED: compiler.errors
|
||||
|
|
@ -24,11 +24,12 @@ IN: tools.deploy.shaker
|
|||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
{
|
||||
"alien.strings"
|
||||
"command-line"
|
||||
"cpu.x86"
|
||||
"destructors"
|
||||
"environment"
|
||||
"libc"
|
||||
"alien.strings"
|
||||
}
|
||||
[ init-hooks get delete-at ] each
|
||||
deploy-threads? get [
|
||||
|
|
@ -65,6 +66,13 @@ IN: tools.deploy.shaker
|
|||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-destructors ( -- )
|
||||
"libc" vocab [
|
||||
"Stripping destructor debug code" show
|
||||
"vocab:tools/deploy/shaker/strip-destructors.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-call ( -- )
|
||||
"Stripping stack effect checking from call( and execute(" show
|
||||
"vocab:tools/deploy/shaker/strip-call.factor" run-file ;
|
||||
|
|
@ -194,12 +202,31 @@ IN: tools.deploy.shaker
|
|||
strip-word-names? [ dup strip-word-names ] when
|
||||
2drop ;
|
||||
|
||||
: compiler-classes ( -- seq )
|
||||
{ "compiler" "stack-checker" }
|
||||
[ child-vocabs [ words ] map concat [ class? ] filter ]
|
||||
map concat unique ;
|
||||
|
||||
: prune-decision-tree ( tree classes -- )
|
||||
[ tuple class>type ] 2dip '[
|
||||
dup array? [
|
||||
[
|
||||
dup array? [
|
||||
[
|
||||
2 group
|
||||
[ drop _ key? not ] assoc-filter
|
||||
concat
|
||||
] map
|
||||
] when
|
||||
] map
|
||||
] when
|
||||
] change-nth ;
|
||||
|
||||
: strip-compiler-classes ( -- )
|
||||
strip-dictionary? [
|
||||
"Stripping compiler classes" show
|
||||
{ "compiler" "stack-checker" }
|
||||
[ child-vocabs [ words ] map concat [ class? ] filter ] map concat
|
||||
[ dup implementors [ "methods" word-prop delete-at ] with each ] each
|
||||
[ single-generic? ] instances
|
||||
compiler-classes '[ "decision-tree" word-prop _ prune-decision-tree ] each
|
||||
] when ;
|
||||
|
||||
: recursive-subst ( seq old new -- )
|
||||
|
|
@ -259,6 +286,8 @@ IN: tools.deploy.shaker
|
|||
|
||||
"mallocs" "libc.private" lookup ,
|
||||
|
||||
"disposables" "destructors" lookup ,
|
||||
|
||||
deploy-threads? [
|
||||
"initial-thread" "threads" lookup ,
|
||||
] unless
|
||||
|
|
@ -424,22 +453,22 @@ SYMBOL: deploy-vocab
|
|||
t "quiet" set-global
|
||||
f output-stream set-global ;
|
||||
|
||||
: unsafe-next-method-quot ( method -- quot )
|
||||
: next-method* ( method -- quot )
|
||||
[ "method-class" word-prop ]
|
||||
[ "method-generic" word-prop ] bi
|
||||
next-method 1quotation ;
|
||||
next-method ;
|
||||
|
||||
: compute-next-methods ( -- )
|
||||
[ standard-generic? ] instances [
|
||||
"methods" word-prop [
|
||||
nip dup
|
||||
unsafe-next-method-quot
|
||||
"next-method-quot" set-word-prop
|
||||
nip dup next-method* "next-method" set-word-prop
|
||||
] assoc-each
|
||||
] each
|
||||
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
|
||||
|
||||
: (clear-megamorphic-cache) ( i array -- )
|
||||
! Can't do any dispatch while clearing caches since that
|
||||
! might leave them in an inconsistent state.
|
||||
2dup 1 slot < [
|
||||
2dup [ f ] 2dip set-array-nth
|
||||
[ 1 + ] dip (clear-megamorphic-cache)
|
||||
|
|
@ -459,14 +488,15 @@ SYMBOL: deploy-vocab
|
|||
: strip ( -- )
|
||||
init-stripper
|
||||
strip-libc
|
||||
strip-destructors
|
||||
strip-call
|
||||
strip-cocoa
|
||||
strip-debugger
|
||||
compute-next-methods
|
||||
strip-init-hooks
|
||||
strip-c-io
|
||||
strip-compiler-classes
|
||||
strip-default-methods
|
||||
strip-compiler-classes
|
||||
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
|
||||
deploy-vocab get vocab-main deploy-boot-quot
|
||||
find-megamorphic-caches
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
USE: kernel
|
||||
IN: destructors.private
|
||||
|
||||
: register-disposable ( obj -- ) drop ; inline
|
||||
|
||||
: unregister-disposable ( obj -- ) drop ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations ;
|
||||
IN: tools.destructors
|
||||
|
||||
HELP: disposables.
|
||||
{ $description "Print the number of disposable objects of each class." } ;
|
||||
|
||||
HELP: leaks
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns." } ;
|
||||
|
||||
ARTICLE: "tools.destructors" "Destructor tools"
|
||||
"The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks."
|
||||
{ $subsection disposables. }
|
||||
{ $subsection leaks }
|
||||
{ $see-also "destructors" } ;
|
||||
|
||||
ABOUT: "tools.destructors"
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes destructors fry kernel math namespaces
|
||||
prettyprint sequences sets sorting ;
|
||||
IN: tools.destructors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: disposable-tally ( -- assoc )
|
||||
disposables get
|
||||
H{ } clone [ [ keys ] dip '[ class _ inc-at ] each ] keep ;
|
||||
|
||||
: subtract-values ( assoc1 assoc2 -- assoc )
|
||||
[ [ keys ] bi@ append prune ] 2keep
|
||||
H{ } clone [
|
||||
'[
|
||||
[ _ _ [ at 0 or ] bi-curry@ bi - ] keep _ set-at
|
||||
] each
|
||||
] keep ;
|
||||
|
||||
: (disposables.) ( assoc -- )
|
||||
>alist sort-keys simple-table. ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: disposables. ( -- )
|
||||
disposable-tally (disposables.) ;
|
||||
|
||||
: leaks ( quot -- )
|
||||
disposable-tally [ call disposable-tally ] dip subtract-values
|
||||
(disposables.) ; inline
|
||||
|
|
@ -7,7 +7,7 @@ cocoa.views cocoa.windows combinators command-line
|
|||
core-foundation core-foundation.run-loop core-graphics
|
||||
core-graphics.types destructors fry generalizations io.thread
|
||||
kernel libc literals locals math math.bitwise math.rectangles memory
|
||||
namespaces sequences specialized-arrays.int threads ui
|
||||
namespaces sequences threads ui
|
||||
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
|
||||
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
|
||||
ui.private words.symbol ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes
|
||||
cocoa.views cocoa.application cocoa.pasteboard cocoa.types
|
||||
cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets
|
||||
cocoa.windows sequences io.encodings.utf8 ui ui.private ui.gadgets
|
||||
ui.gadgets.private ui.gadgets.worlds ui.gestures
|
||||
core-foundation.strings core-graphics core-graphics.types threads
|
||||
combinators math.rectangles ;
|
||||
|
|
@ -220,7 +220,7 @@ CLASS: {
|
|||
{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
|
||||
[
|
||||
nip -> action
|
||||
2dup [ window ] [ ascii alien>string ] bi* validate-action
|
||||
2dup [ window ] [ utf8 alien>string ] bi* validate-action
|
||||
[ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
|
||||
]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ destructors fry math.parser generalizations sets
|
|||
specialized-arrays.alien specialized-arrays.direct.alien ;
|
||||
IN: windows.com.wrapper
|
||||
|
||||
TUPLE: com-wrapper callbacks vtbls disposed ;
|
||||
TUPLE: com-wrapper < disposable callbacks vtbls ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -153,7 +153,7 @@ PRIVATE>
|
|||
[ +live-wrappers+ get adjoin ] bi ;
|
||||
|
||||
: <com-wrapper> ( implementations -- wrapper )
|
||||
(make-callbacks) f f com-wrapper boa
|
||||
com-wrapper new-disposable swap (make-callbacks) >>vtbls
|
||||
dup allocate-wrapper ;
|
||||
|
||||
M: com-wrapper dispose*
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ windows.offscreen windows.gdi32 windows.ole32 windows.types
|
|||
windows.fonts opengl.textures locals windows.errors ;
|
||||
IN: windows.uniscribe
|
||||
|
||||
TUPLE: script-string font string metrics ssa size image disposed ;
|
||||
TUPLE: script-string < disposable font string metrics ssa size image ;
|
||||
|
||||
: line-offset>x ( n script-string -- x )
|
||||
2dup string>> length = [
|
||||
|
|
@ -89,7 +89,7 @@ TUPLE: script-string font string metrics ssa size image disposed ;
|
|||
TEXTMETRIC>metrics ;
|
||||
|
||||
: <script-string> ( font string -- script-string )
|
||||
[ script-string new ] 2dip
|
||||
[ script-string new-disposable ] 2dip
|
||||
[ >>font ] [ >>string ] bi*
|
||||
[
|
||||
{
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ HELP: dispose
|
|||
$nl
|
||||
"No further operations can be performed on a disposable object after this call."
|
||||
$nl
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, inherit from the " { $link disposable } " class and implement the " { $link dispose* } " method instead." }
|
||||
{ $notes "You must dispose of disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
|
||||
$nl
|
||||
"The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
|
||||
|
||||
|
|
@ -51,6 +51,9 @@ HELP: dispose-each
|
|||
{ "seq" sequence } }
|
||||
{ $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ;
|
||||
|
||||
HELP: disposables
|
||||
{ $var-description "Global variable holding all disposable objects which have not been disposed of yet. The " { $link new-disposable } " word adds objects here, and the " { $link dispose } " method on disposables removes them. The " { $link "tools.destructors" } " vocabulary provides some words for working with this data." } ;
|
||||
|
||||
ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
|
||||
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
|
||||
{ $code
|
||||
|
|
@ -58,12 +61,9 @@ ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
|
|||
}
|
||||
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
|
||||
|
||||
ARTICLE: "destructors" "Deterministic resource disposal"
|
||||
"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability."
|
||||
$nl
|
||||
"Disposable object protocol:"
|
||||
ARTICLE: "destructors-using" "Using destructors"
|
||||
"Disposing of an object:"
|
||||
{ $subsection dispose }
|
||||
{ $subsection dispose* }
|
||||
"Utility word for scoped disposal:"
|
||||
{ $subsection with-disposal }
|
||||
"Utility word for disposing multiple objects:"
|
||||
|
|
@ -71,7 +71,23 @@ $nl
|
|||
"Utility words for more complex disposal patterns:"
|
||||
{ $subsection with-destructors }
|
||||
{ $subsection &dispose }
|
||||
{ $subsection |dispose }
|
||||
{ $subsection "destructors-anti-patterns" } ;
|
||||
{ $subsection |dispose } ;
|
||||
|
||||
ARTICLE: "destructors-extending" "Writing new destructors"
|
||||
"Superclass for disposable objects:"
|
||||
{ $subsection disposable }
|
||||
"Parametrized constructor for disposable objects:"
|
||||
{ $subsection new-disposable }
|
||||
"Generic disposal word:"
|
||||
{ $subsection dispose* }
|
||||
"Global set of disposable objects:"
|
||||
{ $subsection disposables } ;
|
||||
|
||||
ARTICLE: "destructors" "Deterministic resource disposal"
|
||||
"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability."
|
||||
{ $subsection "destructors-using" }
|
||||
{ $subsection "destructors-extending" }
|
||||
{ $subsection "destructors-anti-patterns" }
|
||||
{ $see-also "tools.destructors" } ;
|
||||
|
||||
ABOUT: "destructors"
|
||||
|
|
|
|||
|
|
@ -1,10 +1,30 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors continuations kernel namespaces make
|
||||
sequences vectors ;
|
||||
sequences vectors sets assocs init ;
|
||||
IN: destructors
|
||||
|
||||
TUPLE: disposable disposed ;
|
||||
SYMBOL: disposables
|
||||
|
||||
[ H{ } clone disposables set-global ] "destructors" add-init-hook
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: register-disposable ( obj -- )
|
||||
disposables get conjoin ;
|
||||
|
||||
: unregister-disposable ( obj -- )
|
||||
disposables get delete-at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: disposable < identity-tuple disposed id ;
|
||||
|
||||
M: disposable hashcode* nip id>> ;
|
||||
|
||||
: new-disposable ( class -- disposable )
|
||||
new \ disposable counter >>id
|
||||
dup register-disposable ; inline
|
||||
|
||||
GENERIC: dispose* ( disposable -- )
|
||||
|
||||
|
|
@ -18,6 +38,9 @@ GENERIC: dispose ( disposable -- )
|
|||
M: object dispose
|
||||
dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
|
||||
|
||||
M: disposable dispose
|
||||
[ unregister-disposable ] [ call-next-method ] bi ;
|
||||
|
||||
: dispose-each ( seq -- )
|
||||
[
|
||||
[ [ dispose ] curry [ , ] recover ] each
|
||||
|
|
|
|||
|
|
@ -6,7 +6,10 @@ io.encodings.utf8 alien.strings continuations destructors byte-arrays
|
|||
accessors combinators ;
|
||||
IN: io.streams.c
|
||||
|
||||
TUPLE: c-stream handle disposed ;
|
||||
TUPLE: c-stream < disposable handle ;
|
||||
|
||||
: new-c-stream ( handle class -- c-stream )
|
||||
new-disposable swap >>handle ; inline
|
||||
|
||||
M: c-stream dispose* handle>> fclose ;
|
||||
|
||||
|
|
@ -20,7 +23,7 @@ M: c-stream stream-seek
|
|||
|
||||
TUPLE: c-writer < c-stream ;
|
||||
|
||||
: <c-writer> ( handle -- stream ) f c-writer boa ;
|
||||
: <c-writer> ( handle -- stream ) c-writer new-c-stream ;
|
||||
|
||||
M: c-writer stream-element-type drop +byte+ ;
|
||||
|
||||
|
|
@ -32,7 +35,7 @@ M: c-writer stream-flush dup check-disposed handle>> fflush ;
|
|||
|
||||
TUPLE: c-reader < c-stream ;
|
||||
|
||||
: <c-reader> ( handle -- stream ) f c-reader boa ;
|
||||
: <c-reader> ( handle -- stream ) c-reader new-c-stream ;
|
||||
|
||||
M: c-reader stream-element-type drop +byte+ ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue