effects generalizations sequences ;
IN: alien.destructors
-SLOT: alien
+TUPLE: alien-destructor alien ;
FUNCTOR: define-destructor ( F -- )
WHERE
-TUPLE: F-destructor alien disposed ;
+TUPLE: F-destructor < alien-destructor ;
-: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
+: <F-destructor> ( alien -- destructor )
+ F-destructor boa ; inline
-M: F-destructor dispose* alien>> F N ndrop ;
+M: F-destructor dispose alien>> F N ndrop ;
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
! Object cache; we only consider numbers equal if they have the
! same type
-TUPLE: id obj ;
+TUPLE: eql-wrapper obj ;
-C: <id> id
+C: <eql-wrapper> eql-wrapper
-M: id hashcode* obj>> hashcode* ;
+M: eql-wrapper hashcode* obj>> hashcode* ;
GENERIC: (eql?) ( obj1 obj2 -- ? )
M: object (eql?) = ;
-M: id equal?
- over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+M: eql-wrapper equal?
+ over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+TUPLE: eq-wrapper obj ;
+
+C: <eq-wrapper> eq-wrapper
+
+M: eq-wrapper equal?
+ over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
SYMBOL: objects
-: (objects) ( obj -- id assoc ) <id> objects get ; inline
+: cache-eql-object ( obj quot -- value )
+ [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
-: lookup-object ( obj -- n/f ) (objects) at ;
+: cache-eq-object ( obj quot -- value )
+ [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
-: put-object ( n obj -- ) (objects) set-at ;
+: lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
-: cache-object ( obj quot -- value )
- [ (objects) ] dip '[ obj>> @ ] cache ; inline
+: put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
! Constants
M: bignum '
[
bignum [ emit-bignum ] emit-object
- ] cache-object ;
+ ] cache-eql-object ;
! Fixnums
float [
align-here double>bits emit-64
] emit-object
- ] cache-object ;
+ ] cache-eql-object ;
! Special objects
! Wrappers
M: wrapper '
- wrapped>> ' wrapper [ emit ] emit-object ;
+ [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
! Strings
: native> ( object -- object )
M: string '
#! We pool strings so that each string is only written once
#! to the image
- [ emit-string ] cache-object ;
+ [ emit-string ] cache-eql-object ;
: assert-empty ( seq -- )
length 0 assert= ;
] bi* ;
M: byte-array '
- byte-array [
- dup length emit-fixnum
- pad-bytes emit-bytes
- ] emit-object ;
+ [
+ byte-array [
+ dup length emit-fixnum
+ pad-bytes emit-bytes
+ ] emit-object
+ ] cache-eq-object ;
! Tuples
ERROR: tuple-removed class ;
: emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" =
- [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
+ [ [ (emit-tuple) ] cache-eql-object ]
+ [ [ (emit-tuple) ] cache-eq-object ]
+ if ;
M: tuple ' emit-tuple ;
M: tombstone '
state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first
- [ emit-tuple ] cache-object ;
+ [ emit-tuple ] cache-eql-object ;
! Arrays
: emit-array ( array -- offset )
[ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
-M: array ' emit-array ;
+M: array ' [ emit-array ] cache-eq-object ;
! This is a hack. We need to detect arrays which are tuple
! layout arrays so that they can be internalized, but making
[
[ dup integer? [ <fake-bignum> ] when ] map
emit-array
- ] cache-object ;
+ ] cache-eql-object ;
! Quotations
0 emit ! xt
0 emit ! code
] emit-object
- ] cache-object ;
+ ] cache-eql-object ;
! End of the image
"tools.crossref"
"tools.errors"
"tools.deploy"
+ "tools.destructors"
"tools.disassembler"
"tools.memory"
"tools.profiler"
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
<PRIVATE
-TUPLE: evp-md-context handle ;
+TUPLE: evp-md-context < disposable handle ;
: <evp-md-context> ( -- ctx )
- "EVP_MD_CTX" <c-object>
- dup EVP_MD_CTX_init evp-md-context boa ;
+ evp-md-context new-disposable
+ "EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
-M: evp-md-context dispose
+M: evp-md-context dispose*
handle>> EVP_MD_CTX_cleanup drop ;
: with-evp-md-context ( quot -- )
! 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
! 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
[ 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>
{ append-outputs append-outputs-as } related-words
+HELP: drop-outputs
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation and drops any values it leaves on the stack." } ;
+
+HELP: keep-inputs
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation and preserves any values it takes off the stack." } ;
+
+{ drop-outputs keep-inputs } related-words
ARTICLE: "combinators.smart" "Smart combinators"
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
-"Call a quotation and discard all output values:"
+"Call a quotation and discard all output values or preserve all input values:"
{ $subsection drop-outputs }
+{ $subsection keep-inputs }
"Take all input values from a sequence:"
{ $subsection input<sequence }
"Store all output values to a sequence:"
MACRO: drop-outputs ( quot -- quot' )
dup infer out>> '[ @ _ ndrop ] ;
+MACRO: keep-inputs ( quot -- quot' )
+ dup infer in>> '[ _ _ nkeep ] ;
+
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
[ f ] [
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ f ] [
+ [ 1000 [ ] times ]
+ [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
] unit-test
\ No newline at end of file
debugger debugger.threads locals fry ;\r
IN: concurrency.mailboxes\r
\r
-TUPLE: mailbox threads data disposed ;\r
+TUPLE: mailbox < disposable threads data ;\r
\r
M: mailbox dispose* threads>> notify-all ;\r
\r
: <mailbox> ( -- mailbox )\r
- <dlist> <dlist> f mailbox boa ;\r
+ mailbox new-disposable <dlist> >>threads <dlist> >>data ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
data>> deque-empty? ;\r
}
"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*
{
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>
:: <line> ( font string -- line )
[
+ line new-disposable
+
[let* | open-font [ font cache-font ]
line [ string open-font font foreground>> <CTLine> |CFRelease ]
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 ]
[ 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 ;
! frame, 8 bytes in size. This is in the param-save area so it
! does not overlap with spill slots.
: scratch@ ( n -- offset )
- stack-frame get total-size>>
- factor-area-size -
- param-save-size -
- + ;
+ factor-area-size + ;
! GC root area
: gc-root@ ( n -- offset )
{ $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" }
{ $subsection "profiling" }
{ $subsection "tools.memory" }
{ $subsection "tools.threads" }
+{ $subsection "tools.destructors" }
{ $subsection "tools.disassembler" }
{ $heading "Deployment" }
{ $subsection "tools.deploy" } ;
] with-nesting
] ($heading) ;
+: $deprecated ( element -- )
+ [
+ deprecated-style get [
+ last-element off
+ "This word is deprecated" $heading print-element
+ ] with-nesting
+ ] ($heading) ;
+
! Images
: $image ( element -- )
[ first write-image ] ($span) ;
{ wrap-margin 500 }
} warning-style set-global
+SYMBOL: deprecated-style
+H{
+ { page-color COLOR: gray90 }
+ { border-color COLOR: red }
+ { border-width 5 }
+ { wrap-margin 500 }
+} deprecated-style set-global
+
SYMBOL: table-content-style
H{
{ wrap-margin 350 }
} cleave ;
: keyed-vocabs ( str quot -- seq )
- [ all-vocabs ] 2dip '[ [ _ swap @ member? ] filter ] assoc-map ; inline
+ [ all-vocabs-recursive ] 2dip
+ '[ [ _ swap @ member? ] filter no-prefixes ] assoc-map ; inline
: tagged ( tag -- assoc )
[ vocab-tags ] keyed-vocabs ;
unimplemented-color-type ;
: decode-truecolor-alpha ( loading-png -- loading-png )
- unimplemented-color-type ;
+ [ <image> ] dip {
+ [ png-image-bytes >>bitmap ]
+ [ [ width>> ] [ height>> ] bi 2array >>dim ]
+ [ drop RGBA >>component-order ubyte-components >>component-type ]
+ } cleave ;
: decode-png ( loading-png -- loading-png )
dup color-type>> {
max-events epoll_create dup io-error >>fd
max-events "epoll-event" <struct-array> >>events ;
-M: epoll-mx dispose fd>> close-file ;
+M: epoll-mx dispose* fd>> close-file ;
: make-event ( fd events -- event )
"epoll-event" <c-object>
kqueue dup io-error >>fd
max-events "kevent" <struct-array> >>events ;
-M: kqueue-mx dispose fd>> close-file ;
+M: kqueue-mx dispose* fd>> close-file ;
: make-kevent ( fd filter flags -- event )
"kevent" <c-object>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs sequences threads ;
+USING: kernel accessors assocs sequences threads destructors ;
IN: io.backend.unix.multiplexers
-TUPLE: mx fd reads writes ;
+TUPLE: mx < disposable fd reads writes ;
: new-mx ( class -- obj )
- new
+ new-disposable
H{ } clone >>reads
H{ } clone >>writes ; inline
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 )
[
#! 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>> ;
! 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*
[
: 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 ;
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 ;
<win32-file> |dispose
dup add-completion ;
-: share-mode ( -- fixnum )
+: share-mode ( -- n )
{
FILE_SHARE_READ
FILE_SHARE_WRITE
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 -- )
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
path 1array 0 0 <event-stream> >>handle
] ;
-M: macosx-monitor dispose
- handle>> dispose ;
+M: macosx-monitor dispose* handle>> dispose ;
macosx set-io-backend
[ dispose-monitors ] [ ] cleanup
] with-scope ; inline
-TUPLE: monitor < identity-tuple path queue timeout ;
-
-M: monitor hashcode* path>> hashcode* ;
+TUPLE: monitor < disposable path queue timeout ;
M: monitor timeout timeout>> ;
M: monitor set-timeout (>>timeout) ;
: new-monitor ( path mailbox class -- monitor )
- new
+ new-disposable
swap >>queue
swap >>path ; inline
! 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? ;
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 } ;
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 ;
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 ;
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
[ handle>> SSL_CTX_free ]
tri ;
-TUPLE: ssl-handle file handle connected disposed ;
+TUPLE: ssl-handle < disposable file handle connected ;
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 ;
"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 )
! 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>
[ "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
! Test duplex stream close behavior
TUPLE: closing-stream < disposable ;
-: <closing-stream> ( -- stream ) closing-stream new ;
+: <closing-stream> ( -- stream ) closing-stream new-disposable ;
M: closing-stream dispose* drop ;
USING: alien.syntax alien.c-types core-foundation
core-foundation.bundles core-foundation.dictionaries system
-combinators kernel sequences debugger io accessors ;
+combinators kernel sequences io accessors ;
IN: iokit
<<
FUNCTION: char* mach_error_string ( IOReturn error ) ;
-TUPLE: mach-error error-code ;
-C: <mach-error> mach-error
-
-M: mach-error error.
- "IOKit call failed: " print error-code>> mach_error_string print ;
+TUPLE: mach-error error-code error-string ;
+: <mach-error> ( code -- error )
+ dup mach_error_string \ mach-error boa ;
: mach-error ( return -- )
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
\r
100 malloc "block" set\r
\r
-[ t ] [ "block" get mallocs key? ] unit-test\r
+[ t ] [ "block" get malloc-exists? ] unit-test\r
\r
[ ] [ [ "block" get &free drop ] with-destructors ] unit-test\r
\r
-[ f ] [ "block" get mallocs key? ] unit-test\r
+[ f ] [ "block" get malloc-exists? ] unit-test\r
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations alien.destructors kernel
-namespaces accessors sets summary ;
+namespaces accessors sets summary destructors destructors.private ;
IN: libc
: errno ( -- int )
: (realloc) ( alien size -- newalien )
"void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
-: mallocs ( -- assoc )
- \ mallocs [ H{ } clone ] initialize-alien ;
+! We stick malloc-ptr instances in the global disposables set
+TUPLE: malloc-ptr value continuation ;
+
+M: malloc-ptr hashcode* value>> hashcode* ;
+
+M: malloc-ptr equal?
+ over malloc-ptr? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
+
+: <malloc-ptr> ( value -- malloc-ptr )
+ malloc-ptr new swap >>value ;
PRIVATE>
: check-ptr ( c-ptr -- c-ptr )
[ bad-ptr ] unless* ;
-ERROR: double-free ;
-
-M: double-free summary
- drop "Free failed since memory is not allocated" ;
-
ERROR: realloc-error ptr size ;
M: realloc-error summary
<PRIVATE
: add-malloc ( alien -- alien )
- dup mallocs conjoin ;
+ dup <malloc-ptr> register-disposable ;
: delete-malloc ( alien -- )
- [
- mallocs delete-at*
- [ drop ] [ double-free ] if
- ] when* ;
+ [ <malloc-ptr> unregister-disposable ] when* ;
: malloc-exists? ( alien -- ? )
- mallocs key? ;
+ <malloc-ptr> disposables get key? ;
PRIVATE>
"syntax"
"tools.annotations"
"tools.crossref"
+ "tools.destructors"
"tools.disassembler"
"tools.errors"
"tools.memory"
[ T{ interval f { 1 t } { 1 t } } ] [ 1 [a,a] ] unit-test
+! Not sure how to handle NaNs yet...
+! [ 1 0/0. [a,b] ] must-fail
+! [ 0/0. 1 [a,b] ] must-fail
+
[ t ] [ { 3 t } { 3 f } endpoint< ] unit-test
[ t ] [ { 2 f } { 3 f } endpoint< ] unit-test
[ f ] [ { 3 f } { 3 t } endpoint< ] unit-test
[ t ] [ full-interval interval-abs [0,inf] = ] unit-test
+[ t ] [ [0,inf] interval-abs [0,inf] = ] unit-test
+
+[ t ] [ empty-interval interval-abs empty-interval = ] unit-test
+
[ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test
! Test that commutative interval ops really are
<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 [
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
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
: <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 ;
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
: <layout> ( font string -- line )
[
- layout new
+ layout new-disposable
swap unpack-selection
swap >>font
dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
--- /dev/null
+IN: tools.continuations
+USING: help.markup help.syntax ;
+
+HELP: break
+{ $description "A breakpoint. When this word is executed, the walker tool opens with execution suspended at the breakpoint's location." }
+{ $see-also "ui-walker" } ;
\ No newline at end of file
-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 ;
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
: 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 [
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 ;
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 -- )
+ '[
+ _ _
+ {
+ ! old becomes new
+ { [ 3dup drop eq? ] [ 2nip ] }
+ ! recurse into arrays
+ { [ pick array? ] [ [ dup ] 2dip recursive-subst ] }
+ ! otherwise do nothing
+ [ 2drop ]
+ } cond
+ ] change-each ;
+
+: strip-default-method ( generic new-default -- )
+ [
+ [ "decision-tree" word-prop ]
+ [ "default-method" word-prop ] bi
+ ] dip
+ recursive-subst ;
+
+: new-default-method ( -- gensym )
+ [ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ;
+
: strip-default-methods ( -- )
+ ! In a development image, each generic has its own default method.
+ ! This gives better error messages for runtime type errors, but
+ ! takes up space. For deployment we merge them all together.
strip-debugger? [
"Stripping default methods" show
- [
- [ generic? ] instances
- [ "No method" throw ] (( -- * )) define-temp
- dup t "default" set-word-prop
- '[
- [ _ "default-method" set-word-prop ] [ make-generic ] bi
- ] each
- ] with-compilation-unit
+ [ single-generic? ] instances
+ new-default-method '[ _ strip-default-method ] each
] when ;
: strip-vocab-globals ( except names -- words )
"io-thread" "io.thread" lookup ,
- "mallocs" "libc.private" lookup ,
+ "disposables" "destructors" lookup ,
deploy-threads? [
"initial-thread" "threads" lookup ,
[ compress-object? ] [ ] "objects" compress ;
: remain-compiled ( old new -- old new )
- #! Quotations which were formerly compiled must remain
- #! compiled.
+ ! Quotations which were formerly compiled must remain
+ ! compiled.
2dup [
2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
[ nip jit-compile ] [ 2drop ] if
[ boot ] %
init-hooks get values concat %
strip-debugger? [ , ] [
- ! Don't reference try directly
+ ! Don't reference 'try' directly since we don't want
+ ! to pull in the debugger and prettyprinter into every
+ ! deployed app
[:c]
[print-error]
'[
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)
: 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
"threads" vocab [
[
"error-in-thread" "threads" lookup
- [ die 2drop ]
- define
+ [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi
] with-compilation-unit
] when
--- /dev/null
+USE: kernel
+IN: destructors.private
+
+: register-disposable ( obj -- ) drop ; inline
+
+: unregister-disposable ( obj -- ) drop ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax help.tips quotations destructors ;
+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. The " { $link debug-leaks? } " variable is also switched on while the quotation runs, recording the current continuation in every newly-created disposable object." } ;
+
+TIP: "Use the " { $link leaks } " combinator to track down resource leaks." ;
+
+ARTICLE: "tools.destructors" "Destructor tools"
+"The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks."
+{ $subsection debug-leaks? }
+{ $subsection disposables. }
+{ $subsection leaks }
+{ $see-also "destructors" } ;
+
+ABOUT: "tools.destructors"
--- /dev/null
+USING: kernel tools.destructors tools.test destructors namespaces ;
+IN: tools.destructors.tests
+
+f debug-leaks? set-global
+
+[ [ 3 throw ] leaks ] must-fail
+
+[ f ] [ debug-leaks? get-global ] unit-test
+
+[ ] [ [ ] leaks ] unit-test
+
+[ f ] [ debug-leaks? get-global ] unit-test
+
--- /dev/null
+! 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 continuations accessors arrays
+io io.styles combinators.smart ;
+IN: tools.destructors
+
+<PRIVATE
+
+: class-tally ( assoc -- assoc' )
+ H{ } clone [ [ keys ] dip '[ dup class _ push-at ] each ] keep ;
+
+: (disposables.) ( assoc -- )
+ class-tally >alist [ first2 [ length ] keep 3array ] map [ second ] sort-with
+ standard-table-style [
+ [
+ [ "Disposable class" write ] with-cell
+ [ "Instances" write ] with-cell
+ [ ] with-cell
+ ] with-row
+ [
+ [
+ [
+ [ pprint-cell ]
+ [ pprint-cell ]
+ [ [ "[ List instances ]" swap write-object ] with-cell ]
+ tri*
+ ] input<sequence
+ ] with-row
+ ] each
+ ] tabular-output nl ;
+
+: sort-disposables ( seq -- seq' )
+ [ disposable? ] partition [ [ id>> ] sort-with ] dip append ;
+
+PRIVATE>
+
+: disposables. ( -- )
+ disposables get (disposables.) ;
+
+: disposables-of-class. ( class -- )
+ [ disposables get values sort-disposables ] dip
+ '[ _ instance? ] filter stack. ;
+
+: leaks ( quot -- )
+ disposables get clone
+ t debug-leaks? set-global
+ [
+ [ call disposables get clone ] dip
+ ] [ f debug-leaks? set-global ] [ ] cleanup
+ assoc-diff (disposables.) ; inline
--- /dev/null
+IN: tools.walker
+USING: help.syntax help.markup tools.continuations ;
+
+HELP: B
+{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;
\ No newline at end of file
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 ;
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 ;
{ "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
]
}
ERROR: invalid-pixel-format-attributes world attributes ;
-TUPLE: pixel-format world handle ;
+TUPLE: pixel-format < disposable world handle ;
: <pixel-format> ( world attributes -- pixel-format )
2dup (make-pixel-format)
- [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ;
+ [ pixel-format new-disposable swap >>handle swap >>world ]
+ [ invalid-pixel-format-attributes ]
+ ?if ;
-M: pixel-format dispose
+M: pixel-format dispose*
[ (free-pixel-format) ] [ f >>handle drop ] bi ;
: pixel-format-attribute ( pixel-format attribute-name -- value )
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations definitions generic help.topics threads
-stack-checker summary io.pathnames io.styles kernel namespaces parser
-prettyprint quotations tools.crossref tools.annotations editors
-tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
-words sequences classes compiler.errors compiler.units
-accessors vocabs.parser macros.expander ui ui.tools.browser
-ui.tools.listener ui.tools.listener.completion ui.tools.profiler
-ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors
-ui.gestures ui.operations ui.tools.deploy models help.tips
-source-files.errors ;
+stack-checker summary io.pathnames io.styles kernel namespaces
+parser prettyprint quotations tools.crossref tools.annotations
+editors tools.profiler tools.test tools.time tools.walker vocabs
+vocabs.loader words sequences classes compiler.errors
+compiler.units accessors vocabs.parser macros.expander ui
+ui.tools.browser ui.tools.listener ui.tools.listener.completion
+ui.tools.profiler ui.tools.inspector ui.tools.traceback
+ui.commands ui.gadgets.editors ui.gestures ui.operations
+ui.tools.deploy models help.tips source-files.errors destructors
+libc libc.private ;
IN: ui.tools.operations
! Objects
{ +listener+ t }
} define-operation
+! Disposables
+[ disposable? ] \ dispose H{ } define-operation
+
+! Disposables with a continuation
+PREDICATE: tracked-disposable < disposable
+ continuation>> >boolean ;
+
+PREDICATE: tracked-malloc-ptr < malloc-ptr
+ continuation>> >boolean ;
+
+: com-creation-traceback ( disposable -- )
+ continuation>> traceback-window ;
+
+[ tracked-disposable? ] \ com-creation-traceback H{ { +primary+ t } } define-operation
+[ tracked-malloc-ptr? ] \ com-creation-traceback H{ { +primary+ t } } define-operation
+
! Operations -> commands
interactor
"quotation"
$nl\r
"Breakpoints can be inserted directly into code:"\r
{ $subsection break }\r
+{ $subsection POSTPONE: B }\r
"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
\r
ARTICLE: "ui-walker" "UI walker"\r
specialized-arrays.alien specialized-arrays.direct.alien ;
IN: windows.com.wrapper
-TUPLE: com-wrapper callbacks vtbls disposed ;
+TUPLE: com-wrapper < disposable callbacks vtbls ;
<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*
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 = [
TEXTMETRIC>metrics ;
: <script-string> ( font string -- script-string )
- [ script-string new ] 2dip
+ [ script-string new-disposable ] 2dip
[ >>font ] [ >>string ] bi*
[
{
USING: help.markup help.syntax libc kernel continuations io
-sequences ;
+sequences classes ;
IN: destructors
+HELP: debug-leaks?
+{ $var-description "When this variable is on, " { $link new-disposable } " stores the current continuation in the " { $link disposable } "'s " { $slot "continuation" } " slot." }
+{ $see-also "tools.destructors" } ;
+
+HELP: disposable
+{ $class-description "Parent class for disposable resources. This class has three slots:"
+ { $list
+ { { $slot "disposed" } " - boolean. Set to true by " { $link dispose } ". Assert that it is false with " { $link check-disposed } "." }
+ { { $slot "id" } " - unique identifier. Set by " { $link new-disposable } "." }
+ { { $slot "continuation" } " - current continuation at construction time, for debugging. Set by " { $link new-disposable } " if " { $link debug-leaks? } " is on." }
+ }
+"New instances must be constructed with " { $link new-disposable } " and subclasses must implement " { $link dispose* } "." } ;
+
+HELP: new-disposable
+{ $values { "class" class } { "disposable" disposable } }
+{ $description "Constructs a new instance of a subclass of " { $link disposable } ". This sets the " { $slot "id" } " slot, registers the new object with the global " { $link disposables } " set, and if " { $link debug-leaks? } " is on, stores the current continuation in the " { $slot "continuation" } " slot." } ;
+
HELP: dispose
{ $values { "disposable" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
$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 } "." } ;
{ "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." }
+{ $see-also "tools.destructors" } ;
+
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
}
"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:"
"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"
USING: destructors kernel tools.test continuations accessors
-namespaces sequences ;
+namespaces sequences destructors.private ;
IN: destructors.tests
TUPLE: dispose-error ;
] ignore-errors destroyed?>>
] unit-test
+TUPLE: silly-disposable < disposable ;
+
+M: silly-disposable dispose* drop ;
+
+silly-disposable new-disposable "s" set
+"s" get dispose
+[ "s" get unregister-disposable ]
+[ disposable>> silly-disposable? ]
+must-fail-with
-! 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 math ;
IN: destructors
-TUPLE: disposable disposed ;
+SYMBOL: disposables
+
+[ H{ } clone disposables set-global ] "destructors" add-init-hook
+
+ERROR: already-unregistered disposable ;
+
+SYMBOL: debug-leaks?
+
+<PRIVATE
+
+SLOT: continuation
+
+: register-disposable ( obj -- )
+ debug-leaks? get-global [ continuation >>continuation ] when
+ disposables get conjoin ;
+
+: unregister-disposable ( obj -- )
+ disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
+
+PRIVATE>
+
+TUPLE: disposable < identity-tuple
+{ id integer }
+{ disposed boolean }
+continuation ;
+
+M: disposable hashcode* nip id>> ;
+
+: new-disposable ( class -- disposable )
+ new \ disposable counter >>id
+ dup register-disposable ; inline
GENERIC: dispose* ( disposable -- )
M: object dispose
dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
+M: disposable dispose
+ dup disposed>> [ drop ] [
+ [ unregister-disposable ]
+ [ call-next-method ]
+ bi
+ ] if ;
+
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
"non-byte-array-error" unique-file binary [
"" write
] with-file-writer
-] [ no-method? ] must-fail-with
\ No newline at end of file
+] [ no-method? ] must-fail-with
+
+! What happens if we close a file twice?
+[ ] [
+ "closing-twice" unique-file ascii <file-writer>
+ [ dispose ] [ dispose ] bi
+] unit-test
\ No newline at end of file
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 ;
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+ ;
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+ ;
HELP: deprecated
{ $syntax ": foo ... ; deprecated" }
-{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ;
+{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted by the " { $link "tools.errors" } " system." }
+{ $notes "Code that uses deprecated words continues to function normally; the errors are purely informational. However, code that uses deprecated words should be updated, for the deprecated words are intended to be removed soon." } ;
HELP: SYNTAX:
{ $syntax "SYNTAX: foo ... ;" }
{ $notes "Named fragment shader outputs require OpenGL 3.0 or later and GLSL 1.30 or later, or OpenGL 2.0 or later and GLSL 1.20 or earlier with the " { $snippet "GL_EXT_gpu_shader4" } " extension." } ;
HELP: program
-{ $class-description "A " { $snippet "program" } " provides a specification for linking a " { $link program-instance } " in a graphics context. Programs are defined with " { $link POSTPONE: GLSL-PROGRAM: } " and instantiated
in a context with " { $link <program-instance> } "." } ;
+{ $class-description "A " { $snippet "program" } " provides a specification for linking a " { $link program-instance } " in a graphics context. Programs are defined with " { $link POSTPONE: GLSL-PROGRAM: } " and instantiated
for a context with " { $link <program-instance> } "." } ;
HELP: program-instance
{ $class-description "A " { $snippet "program-instance" } " is a shader " { $link program } " that has been compiled and linked for a graphics context using " { $link <program-instance> } "." } ;
{ $values
{ "program" program }
}
-{ $description "Rereads the source code for every " { $link shader } " in " { $link program } " and attempts to refresh all the existing " { $link shader-instance } "s and " { $link program-instance } "s for those programs. If the new source code fails to compile or link, the existing instances are untouched; otherwise, they are updated on the fly to reference the newly compiled code." } ;
+{ $description "Rereads the source code for every " { $link shader } " in " { $link program } " and attempts to refresh all the existing " { $link shader-instance } "s and " { $link program-instance } "s for those shaders. If any of the new source code fails to compile or link, the existing valid shader and program instances will remain untouched. However, subsequent attempts to compile new shader or program instances will still attempt to use the new source code. If the compilation and linking succeed, the existing shader and program instances will be updated on the fly to reference the newly compiled code." } ;
HELP: shader
-{ $class-description "A " { $snippet "shader" } " provides a block of GLSL source code that can be compiled into a " { $link shader-instance } " in a graphics context. Shaders are defined with " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " and instantiated in a context with " { $link <shader-instance> } "." } ;
+{ $class-description "A " { $snippet "shader" } " provides a block of GLSL source code that can be compiled into a " { $link shader-instance } " in a graphics context. Shaders are defined with " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " and instantiated for a context with " { $link <shader-instance> } "." } ;
HELP: shader-instance
{ $class-description "A " { $snippet "shader-instance" } " is a " { $link shader } " that has been compiled for a graphics context using " { $link <shader-instance> } "." } ;
}
{ $description "Requests " { $snippet "size" } " bytes from a " { $link pile } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ;
+HELP: <pile-c-array>
+{ $values
+ { "pile" pile } { "n" integer } { "c-type" "a C type" }
+ { "alien" alien }
+}
+{ $description "Requests enough space from a " { $link pile } " to hold " { $snippet "n" } " values of " { $snippet "c-type" } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ;
+
+HELP: <pile-c-object>
+{ $values
+ { "pile" pile } { "c-type" "a C type" }
+ { "alien" alien }
+}
+{ $description "Requests enough space from a " { $link pile } " to hold a value of " { $snippet "c-type" } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ;
+
HELP: pile-empty
{ $values
{ "pile" pile }
"A " { $link pile } " is a block of raw memory. Portions of its memory can be allocated from the beginning of the pile in constant time, and the pile can be emptied and its pointer reset to the beginning."
{ $subsection <pile> }
{ $subsection pile-alloc }
+{ $subsection <pile-c-array> }
+{ $subsection <pile-c-object> }
{ $subsection pile-align }
{ $subsection pile-empty }
"An example of the utility of piles is in video games. For example, the game Abuse was scripted with a Lisp dialect. In order to avoid stalls from traditional GC or heap-based allocators, the Abuse Lisp VM would allocate values from a preallocated pile over the course of a frame, and release the entire pile at the end of the frame." ;
! (c)2009 Joe Groff bsd license
-USING: accessors alien destructors kernel libc math ;
+USING: accessors alien alien.c-types destructors kernel libc math ;
IN: memory.piles
TUPLE: pile
[ + ] curry change-offset drop
] 2tri ;
+: <pile-c-object> ( pile c-type -- alien )
+ heap-size pile-alloc ; inline
+
+: <pile-c-array> ( pile n c-type -- alien )
+ heap-size * pile-alloc ; inline
+
: pile-align ( pile align -- pile )
[ align ] curry change-offset ;
projects / factor.git / commitdiff