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

basis/alien/destructors/destructors.factor

@@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words
 effects generalizations sequences ;
 IN: alien.destructors
 
-SLOT: alien
+TUPLE: alien-destructor alien ;
 
 FUNCTOR: define-destructor ( F -- )
 
@@ -16,12 +16,12 @@ N [ F stack-effect out>> length ]
 
 WHERE
 
-TUPLE: F-destructor < disposable alien ;
+TUPLE: F-destructor < alien-destructor ;
 
 : <F-destructor> ( alien -- destructor )
-    F-destructor new-disposable swap >>alien ; inline
+    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
 

basis/checksums/openssl/openssl.factor

@@ -19,13 +19,13 @@ C: <openssl-checksum> openssl-checksum
 
 <PRIVATE
 
-TUPLE: evp-md-context handle ;
+TUPLE: evp-md-context < disposable handle ;
 
 : <evp-md-context> ( -- ctx )
-    "EVP_MD_CTX" <c-object>
+    evp-md-context new-disposable
-    dup EVP_MD_CTX_init evp-md-context boa ;
+    "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 -- )

basis/help/vocabs/vocabs.factor

@@ -249,7 +249,8 @@ C: <vocab-author> vocab-author
     } 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 ;

basis/io/backend/unix/multiplexers/epoll/epoll.factor

@@ -18,7 +18,7 @@ TUPLE: epoll-mx < mx events ;
         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>

basis/io/backend/unix/multiplexers/kqueue/kqueue.factor

@@ -17,7 +17,7 @@ TUPLE: kqueue-mx < mx events ;
         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>

basis/io/backend/unix/multiplexers/multiplexers.factor

@@ -1,12 +1,12 @@
 ! 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
 

basis/io/monitors/macosx/macosx.factor

@@ -17,7 +17,6 @@ M:: macosx (monitor) ( path recursive? mailbox -- monitor )
         path 1array 0 0 <event-stream> >>handle
     ] ;
 
-M: macosx-monitor dispose
+M: macosx-monitor dispose* handle>> dispose ;
-    handle>> dispose ;
 
 macosx set-io-backend

basis/io/monitors/monitors.factor

@@ -22,8 +22,6 @@ M: object dispose-monitors ;
 
 TUPLE: monitor < disposable path queue timeout ;
 
-M: monitor hashcode* path>> hashcode* ;
-
 M: monitor timeout timeout>> ;
 
 M: monitor set-timeout (>>timeout) ;

basis/io/streams/duplex/duplex-tests.factor

@@ -5,7 +5,7 @@ IN: io.streams.duplex.tests
 ! 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 ;
 

basis/libc/libc-tests.factor

@@ -4,8 +4,8 @@ destructors kernel ;
 
 100 malloc "block" set
 
-[ t ] [ "block" get mallocs key? ] unit-test
+[ t ] [ "block" get malloc-exists? ] unit-test
 
 [ ] [ [ "block" get &free drop ] with-destructors ] unit-test
 
-[ f ] [ "block" get mallocs key? ] unit-test
+[ f ] [ "block" get malloc-exists? ] unit-test

basis/libc/libc.factor

@@ -3,7 +3,7 @@
 ! 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 )
@@ -26,8 +26,16 @@ IN: libc
 : (realloc) ( alien size -- newalien )
     "void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
 
-: mallocs ( -- assoc )
+! We stick malloc-ptr instances in the global disposables set
-    \ mallocs [ H{ } clone ] initialize-alien ;
+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>
 
@@ -39,11 +47,6 @@ M: bad-ptr summary
 : 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
@@ -52,16 +55,13 @@ M: realloc-error summary
 <PRIVATE
 
 : add-malloc ( alien -- alien )
-    dup mallocs conjoin ;
+    dup <malloc-ptr> register-disposable ;
 
 : delete-malloc ( alien -- )
-    [
+    [ <malloc-ptr> unregister-disposable ] when* ;
-        mallocs delete-at*
-        [ drop ] [ double-free ] if
-    ] when* ;
 
 : malloc-exists? ( alien -- ? )
-    mallocs key? ;
+    <malloc-ptr> disposables get key? ;
 
 PRIVATE>
 

basis/listener/listener.factor

@@ -163,6 +163,7 @@ SYMBOL: interactive-vocabs
     "syntax"
     "tools.annotations"
     "tools.crossref"
+    "tools.destructors"
     "tools.disassembler"
     "tools.errors"
     "tools.memory"

basis/tools/deploy/shaker/shaker.factor

@@ -284,8 +284,6 @@ IN: tools.deploy.shaker
 
         "io-thread" "io.thread" lookup ,
 
-        "mallocs" "libc.private" lookup ,
-
         "disposables" "destructors" lookup ,
 
         deploy-threads? [

basis/tools/destructors/destructors-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations ;
+USING: help.markup help.syntax help.tips quotations destructors ;
 IN: tools.destructors
 
 HELP: disposables.
@@ -10,10 +10,13 @@ HELP: leaks
 { $values
     { "quot" quotation }
 }
-{ $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns." } ;
+{ $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" } ;

basis/tools/destructors/destructors-tests.factor

@@ -0,0 +1,13 @@
+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
+

basis/tools/destructors/destructors.factor

@@ -1,31 +1,51 @@
 ! 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 ;
+prettyprint sequences sets sorting continuations accessors arrays
+io io.styles combinators.smart ;
 IN: tools.destructors
 
 <PRIVATE
 
-: disposable-tally ( -- assoc )
+: class-tally ( assoc -- assoc' )
-    disposables get
+    H{ } clone [ [ keys ] dip '[ dup class _ push-at ] each ] keep ;
-    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. ;
+    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. ( -- )
-    disposable-tally (disposables.) ;
+    disposables get (disposables.) ;
+
+: disposables-of-class. ( class -- )
+    [ disposables get values sort-disposables ] dip
+    '[ _ instance? ] filter stack. ;
 
 : leaks ( quot -- )
-    disposable-tally [ call disposable-tally ] dip subtract-values
+    disposables get clone
-    (disposables.) ; inline
+    t debug-leaks? set-global
+    [
+        [ call disposables get clone ] dip
+    ] [ f debug-leaks? set-global ] [ ] cleanup
+     assoc-diff (disposables.) ; inline

basis/ui/pixel-formats/pixel-formats.factor

@@ -46,13 +46,15 @@ HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value
 
 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 )

basis/ui/tools/operations/operations.factor

@@ -1,15 +1,16 @@
 ! 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
+stack-checker summary io.pathnames io.styles kernel namespaces
-prettyprint quotations tools.crossref tools.annotations editors
+parser prettyprint quotations tools.crossref tools.annotations
-tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
+editors tools.profiler tools.test tools.time tools.walker vocabs
-words sequences classes compiler.errors compiler.units
+vocabs.loader words sequences classes compiler.errors
-accessors vocabs.parser macros.expander ui ui.tools.browser
+compiler.units accessors vocabs.parser macros.expander ui
-ui.tools.listener ui.tools.listener.completion ui.tools.profiler
+ui.tools.browser ui.tools.listener ui.tools.listener.completion
-ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors
+ui.tools.profiler ui.tools.inspector ui.tools.traceback
-ui.gestures ui.operations ui.tools.deploy models help.tips
+ui.commands ui.gadgets.editors ui.gestures ui.operations
-source-files.errors ;
+ui.tools.deploy models help.tips source-files.errors destructors
+libc libc.private ;
 IN: ui.tools.operations
 
 ! Objects
@@ -182,6 +183,22 @@ M: word com-stack-effect 1quotation com-stack-effect ;
     { +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"

basis/windows/com/wrapper/wrapper.factor

@@ -153,7 +153,7 @@ PRIVATE>
     [ +live-wrappers+ get adjoin ] bi ;
 
 : <com-wrapper> ( implementations -- wrapper )
-    com-wrapper new-disposable swap (make-callbacks) >>vtbls
+    com-wrapper new-disposable swap (make-callbacks) >>callbacks
     dup allocate-wrapper ;
 
 M: com-wrapper dispose*

core/destructors/destructors-docs.factor

@@ -1,7 +1,24 @@
 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."
@@ -52,7 +69,8 @@ HELP: dispose-each
 { $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." } ;
+{ $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:"

core/destructors/destructors-tests.factor

@@ -1,5 +1,5 @@
 USING: destructors kernel tools.test continuations accessors
-namespaces sequences ;
+namespaces sequences destructors.private ;
 IN: destructors.tests
 
 TUPLE: dispose-error ;
@@ -66,3 +66,12 @@ M: dummy-destructor dispose ( obj -- )
     ] 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

core/destructors/destructors.factor

@@ -1,24 +1,34 @@
 ! 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 sets assocs init ;
+sequences vectors sets assocs init math ;
 IN: destructors
 
 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 delete-at ;
+    disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
 
 PRIVATE>
 
-TUPLE: disposable < identity-tuple disposed id ;
+TUPLE: disposable < identity-tuple
+{ id integer }
+{ disposed boolean }
+continuation ;
 
 M: disposable hashcode* nip id>> ;
 
@@ -39,7 +49,11 @@ M: object dispose
     dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
 
 M: disposable dispose
-    [ unregister-disposable ] [ call-next-method ] bi ;
+    dup disposed>> [ drop ] [
+        [ unregister-disposable ]
+        [ call-next-method ]
+        bi
+    ] if ;
 
 : dispose-each ( seq -- )
     [

core/io/files/files-tests.factor

@@ -152,4 +152,10 @@ USE: debugger.threads
     "non-byte-array-error" unique-file binary [
         "" write
     ] with-file-writer
-] [ no-method? ] must-fail-with
+] [ 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

extra/alien/marshall/marshall.factor

@@ -93,7 +93,7 @@ ALIAS: marshall-void* marshall-pointer
 
 : primitive-marshaller ( type -- quot/f )
     {
-        { "bool"        [ [ marshall-bool ] ] }
+        { "bool"        [ [ ] ] }
         { "boolean"     [ [ marshall-bool ] ] }
         { "char"        [ [ marshall-primitive ] ] }
         { "uchar"       [ [ marshall-primitive ] ] }
@@ -179,7 +179,7 @@ ALIAS: marshall-void* marshall-pointer
 
 : primitive-unmarshaller ( type -- quot/f )
     {
-        { "bool"       [ [ unmarshall-bool ] ] }
+        { "bool"       [ [ ] ] }
         { "boolean"    [ [ unmarshall-bool ] ] }
         { "char"       [ [ ] ] }
         { "uchar"      [ [ ] ] }

extra/alien/marshall/syntax/syntax-tests.factor

@@ -9,8 +9,7 @@ C-LIBRARY: test
 
 C-INCLUDE: <stdlib.h>
 C-INCLUDE: <string.h>
-
+C-INCLUDE: <stdbool.h>
-C-TYPEDEF: char bool
 
 CM-FUNCTION: void outarg1 ( int* a )
     *a += 2;