[ stream>> dispose ] [ drop ] if ;
: with-connection ( remote-thread quot -- )
- '[ connect @ ] over [ disconnect ] curry [ ] cleanup ; inline
+ '[ connect @ ] over [ disconnect ] curry finally ; inline
: send-remote-message ( message node -- )
binary [ serialize ] with-client ;
:: do-lock ( lock timeout quot acquire release -- )
lock timeout acquire call
- quot lock release curry [ ] cleanup ; inline
+ quot lock release curry finally ; inline
: (with-lock) ( lock timeout quot -- )
[ acquire-lock ] [ release-lock ] do-lock ; inline
:: with-semaphore-timeout ( semaphore timeout quot -- )
semaphore timeout acquire-timeout
- quot [ semaphore release ] [ ] cleanup ; inline
+ quot [ semaphore release ] finally ; inline
: with-semaphore ( semaphore quot -- )
- swap dup acquire '[ _ release ] [ ] cleanup ; inline
+ swap dup acquire '[ _ release ] finally ; inline
: with-disposals ( object quotation -- )
over sequence? [
- over '[ _ dispose-each ] [ ] cleanup
+ over '[ _ dispose-each ] finally
] [
with-disposal
] if ; inline
: with-os-env ( value key quot -- )
over [ [ [ set-os-env ] 2curry ] [ compose ] bi* ] dip
- [ os-env ] keep [ set-os-env ] 2curry [ ] cleanup ; inline
+ [ os-env ] keep [ set-os-env ] 2curry finally ; inline
{
{ [ os unix? ] [ "environment.unix" require ] }
] unless ;
: with-game-input ( quot -- )
- open-game-input [ close-game-input ] [ ] cleanup ; inline
+ open-game-input [ close-game-input ] finally ; inline
TUPLE: controller handle ;
TUPLE: controller-state x y z rx ry rz slider pov buttons ;
M: wrapped-hash-set pprint*
nesting-limit inc
- [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
+ [ pprint-object ] [ nesting-limit dec ] finally ;
M: wrapped-hashtable pprint*
nesting-limit inc
- [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
+ [ pprint-object ] [ nesting-limit dec ] finally ;
: with-unix-directory ( path quot -- )
dupd '[ _ _
[ opendir dup [ throw-errno ] unless ] dip
- dupd curry swap '[ _ closedir io-error ] [ ] cleanup
+ dupd curry swap '[ _ closedir io-error ] finally
] with-directory ; inline
: dirent-type>file-type ( type -- file-type )
produce nip
over name>> "." = [ nip ] [ swap prefix ] if
]
- ] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi [ ] cleanup ;
+ ] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi finally ;
[ _ find-next-volume dup ] [ ] produce nip
swap prefix
]
- ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+ ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi finally ;
! Windows may return a volume which looks up to path ""
! For now, treat it like there is not a volume here
:: cleanup-unique-file ( ..a prefix suffix quot: ( ..a path -- ..b ) -- ..b )
prefix suffix unique-file :> path
- [ path quot call ] [ path delete-file ] [ ] cleanup ; inline
+ [ path quot call ] [ path delete-file ] finally ; inline
:: cleanup-unique-files ( ..a prefix suffixes quot: ( ..a paths -- ..b ) -- ..b )
prefix suffixes unique-files :> paths
- [ paths quot call ] [ paths [ delete-file ] each ] [ ] cleanup ; inline
+ [ paths quot call ] [ paths [ delete-file ] each ] finally ; inline
: unique-directory ( -- path )
[
:: cleanup-unique-directory ( quot -- )
unique-directory :> path
[ path quot with-directory ]
- [ path delete-tree ] [ ] cleanup ; inline
+ [ path delete-tree ] finally ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
: with-monitors ( quot -- )
[
init-monitors
- [ dispose-monitors ] [ ] cleanup
+ [ dispose-monitors ] finally
] with-scope ; inline
TUPLE: monitor < disposable path queue timeout ;
'[
[ _ threaded-server _ with-variable ]
[ _ stop-server ]
- [ ] cleanup
+ finally
] call ; inline
<PRIVATE
! Always call disable-ctrl-break, no matter what handle-ctrl-break
! says: it might've been changed just now by the user in the Listener.
! It's a no-op if it's not enabled.
- [ disable-ctrl-break ] [ ] cleanup ; inline
+ [ disable-ctrl-break ] finally ; inline
: parse-lines-interactive ( lines -- quot/f )
[ [ parse-lines ] with-ctrl-break ] with-compilation-unit ;
[ close-log-streams path \ log-root set-global quot call ]
\ log-root get-global
[ \ log-root set-global close-log-streams ] curry
- [ ] cleanup ; inline
+ finally ; inline
: timestamp-header. ( -- )
"[" write now (timestamp>rfc3339) "] " write ;
:: with-denormal-mode ( mode quot -- )
denormal-mode :> orig
mode set-denormal-mode
- quot [ orig set-denormal-mode ] [ ] cleanup ; inline
+ quot [ orig set-denormal-mode ] finally ; inline
: rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
:: with-rounding-mode ( mode quot -- )
rounding-mode :> orig
mode set-rounding-mode
- quot [ orig set-rounding-mode ] [ ] cleanup ; inline
+ quot [ orig set-rounding-mode ] finally ; inline
: fp-traps ( -- exceptions )
(fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
clear-fp-exception-flags
fp-traps :> orig
exceptions set-fp-traps
- quot [ orig set-fp-traps ] [ ] cleanup ; inline
+ quot [ orig set-fp-traps ] finally ; inline
: without-fp-traps ( quot -- )
{ } swap with-fp-traps ; inline
: with-locked-model ( model quot -- )
[ '[ _ t >>locked? @ ] ]
[ drop '[ f _ locked?<< ] ]
- 2bi [ ] cleanup ; inline
+ 2bi finally ; inline
GENERIC: update-model ( model -- )
: with-framebuffer ( id quot -- )
[ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ] dip
- [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer ] [ ] cleanup ; inline
+ [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer ] finally ; inline
: with-draw-read-framebuffers ( draw-id read-id quot -- )
[
[
GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer
GL_READ_FRAMEBUFFER 0 glBindFramebuffer
- ] [ ] cleanup ; inline
+ ] finally ; inline
: framebuffer-attachment ( attachment -- id )
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
:: with-gl-buffer ( binding id quot -- )
binding id glBindBuffer
- quot [ binding 0 glBindBuffer ] [ ] cleanup ; inline
+ quot [ binding 0 glBindBuffer ] finally ; inline
: with-array-element-buffers ( array-buffer element-buffer quot -- )
[ GL_ELEMENT_ARRAY_BUFFER ] 2dip '[
:: with-vertex-array ( id quot -- )
id glBindVertexArray
- quot [ 0 glBindVertexArray ] [ ] cleanup ; inline
+ quot [ 0 glBindVertexArray ] finally ; inline
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [
] each glDeleteProgram ;
: with-gl-program ( program quot -- )
- over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
+ over glUseProgram [ 0 glUseProgram ] finally ; inline
PREDICATE: gl-program < integer (gl-program?) ;
: with-extra-nesting-level ( quot -- )
nesting-limit [ dup [ 1 + ] [ f ] if* ] change
- [ nesting-limit set ] curry [ ] cleanup ; inline
+ [ nesting-limit set ] curry finally ; inline
M: hashtable pprint*
[ pprint-object ] with-extra-nesting-level ;
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
-{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
+{ 2 1 } [ [ + ] [ ] finally ] must-infer-as
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
! A typo
_
[ coverage-on test-vocab coverage-off ]
[ coverage ] bi
- ] [ _ remove-coverage ] [ ] cleanup
+ ] [ _ remove-coverage ] finally
] call
] bi ;
t debug-leaks? set-global
[
[ call disposables get clone ] dip
- ] [ f debug-leaks? set-global ] [ ] cleanup
+ ] [ f debug-leaks? set-global ] finally
diff ; inline
: leaks. ( quot -- )
: profile ( quot -- )
samples-per-second get-global profiling
[ 0 profiling (get-samples) raw-profile-data set-global ]
- [ ] cleanup ; inline
+ finally ; inline
: total-sample-count ( sample -- count ) 0 swap nth ;
: gc-sample-count ( sample -- count ) 1 swap nth ;
source G_PRIORITY_DEFAULT_IDLE g_source_set_priority
source f g_source_attach drop
[ quot call( -- ) ]
- [ source g_source_destroy ] [ ] cleanup ;
+ [ source g_source_destroy ] finally ;
! User input
[
source g_source_destroy
start-io-thread
- ] [ ] cleanup ;
+ ] finally ;
init-win32-ui
start-ui
event-loop
- ] [ cleanup-win32-ui ] [ ] cleanup ;
+ ] [ cleanup-win32-ui ] finally ;
M: windows-ui-backend beep
0 MessageBeep drop ;
f ui-running set-global
! Give running ui threads a chance to finish.
notify-ui-thread yield
- ] [ ] cleanup
+ ] finally
] if ;
HOOK: beep ui-backend ( -- )
: (with-real-group) ( string/id quot -- )
'[ _ set-real-group @ ]
- real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
+ real-group-id '[ _ set-real-group ] finally ; inline
: with-real-group ( string/id/f quot -- )
over [ (with-real-group) ] [ nip call ] if ; inline
: (with-effective-group) ( string/id quot -- )
'[ _ set-effective-group @ ]
- effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
+ effective-group-id '[ _ set-effective-group ] finally ; inline
: with-effective-group ( string/id/f quot -- )
over [ (with-effective-group) ] [ nip call ] if ; inline
swap -
] unit-test
-] [ test-sigusr1-handler SIGUSR1 remove-signal-handler ] [ ] cleanup
+] [ test-sigusr1-handler SIGUSR1 remove-signal-handler ] finally
{ 0 } [
sigusr1-count get-global
: with-pwent ( quot -- )
setpwent
- [ unix.ffi:endpwent ] [ ] cleanup ; inline
+ [ unix.ffi:endpwent ] finally ; inline
PRIVATE>
: (with-real-user) ( string/id quot -- )
'[ _ set-real-user @ ]
real-user-id '[ _ set-real-user ]
- [ ] cleanup ; inline
+ finally ; inline
: with-real-user ( string/id/f quot -- )
over [ (with-real-user) ] [ nip call ] if ; inline
: (with-effective-user) ( string/id quot -- )
'[ _ set-effective-user @ ]
effective-user-id '[ _ set-effective-user ]
- [ ] cleanup ; inline
+ finally ; inline
: with-effective-user ( string/id/f quot -- )
over [ (with-effective-user) ] [ nip call ] if ; inline
utmpx-record new ;
: with-utmpx ( quot -- )
- setutxent [ endutxent ] [ ] cleanup ; inline
+ setutxent [ endutxent ] finally ; inline
: all-utmpx ( -- seq )
[
changed-vocabs get-global
f changed-vocabs set-global
{ t } [ "kernel" changed-vocab? ] unit-test
- [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+ [ "kernel" changed-vocab ] [ changed-vocabs set-global ] finally
] unit-test
[ IUnknown::Release drop ] [ null-com-release ] if* ; inline
: with-com-interface ( interface quot -- )
- over [ com-release ] curry [ ] cleanup ; inline
+ over [ com-release ] curry finally ; inline
DESTRUCTOR: com-release
! quot: ( token-handle -- token-handle )
[ open-process-token ] dip
[ keep ] curry
- [ CloseHandle drop ] [ ] cleanup ; inline
+ [ CloseHandle drop ] finally ; inline
: lookup-privilege ( string -- luid )
[ f ] dip LUID <struct>
: with-privileges ( seq quot -- )
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
- 2bi [ ] cleanup ; inline
+ 2bi finally ; inline
key subkey mode open-key :> hkey
[ hkey quot call ]
[ hkey close-key ]
- [ ] cleanup ; inline
+ finally ; inline
:: with-create-registry-key ( key subkey quot -- )
key subkey create-key :> hkey
[ hkey quot call ]
[ hkey close-key ]
- [ ] cleanup ; inline
+ finally ; inline
<PRIVATE
: close-x ( -- ) dpy get XCloseDisplay drop ;
: with-x ( display-string quot -- )
- [ init-x ] dip [ close-x ] [ ] cleanup ; inline
+ [ init-x ] dip [ close-x ] finally ; inline
{ "x11" "io.backend.unix" } "x11.io.unix" require-when
xim get-global XCloseIM drop f xim set-global ;
: with-xim ( quot -- )
- [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline
+ [ "Factor" init-xim ] dip [ close-xim ] finally ; inline
: create-xic ( window classname -- xic )
[
[ callbacks get delete-values ] [ free-callback ] bi ;
: with-callback ( alien quot -- )
- over [ unregister-and-free-callback ] curry [ ] cleanup ; inline
+ over [ unregister-and-free-callback ] curry finally ; inline
: initialize-alien ( symbol quot -- )
swap dup get-global dup recompute-value?
[
remove-nesting-observer
finish-compilation-unit
- ] [ ] cleanup
+ ] finally
] with-variables ; inline
: with-compilation-unit ( quot -- )
{ $values { "error" object } }
{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
-{ cleanup recover } related-words
+{ cleanup recover finally } related-words
HELP: cleanup
{ $values { "try" { $quotation ( ..a -- ..a ) } } { "cleanup-always" { $quotation ( ..a -- ..b ) } } { "cleanup-error" { $quotation ( ..b -- ..b ) } } }
{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
+HELP: finally
+{ $values { "try" { $quotation ( ..a -- ..a ) } } { "cleanup-always" { $quotation ( ..a -- ..b ) } } }
+{ $description "Same as " { $link cleanup } ", but with empty " { $snippet "cleanup-error" } " quotation. Useful when some cleanup code needs to be run after the " { $snippet "try" } " quotation whether an error was thrown or not, but when nothing specific needs to be done about any errors." } ;
+
HELP: recover
{ $values { "try" { $quotation ( ..a -- ..b ) } } { "recovery" { $quotation ( ..a error -- ..b ) } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
: cleanup ( try cleanup-always cleanup-error -- )
[ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
+: finally ( try cleanup-always -- )
+ [ ] cleanup ; inline
+
ERROR: attempt-all-error ;
: attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
[ last rethrow ] unless-empty ;
: with-disposal ( object quot -- )
- over [ dispose ] curry [ ] cleanup ; inline
+ over [ dispose ] curry finally ; inline
<PRIVATE
manifest get current-vocab>> t or in-definition delete ;
: with-definition ( quot -- )
- [ set-in-definition ] prepose [ unset-in-definition ] [ ] cleanup ; inline
+ [ set-in-definition ] prepose [ unset-in-definition ] finally ; inline
: (:) ( -- word def effect )
[
[
"resource:core" normalize-path
[ cwd = ] [ cd ] [ cwd = ] tri
- ] cwd '[ _ dup cd cwd = ] [ ] cleanup
+ ] cwd '[ _ dup cd cwd = ] finally
] unit-test
{ t } [
] with-variable ;
: watch-gvn ( path quot -- )
- annotate-gvn [ test-gvn ] [ reset-gvn ] [ ] cleanup ;
+ annotate-gvn [ test-gvn ] [ reset-gvn ] finally ;
: watch-gvn-cfg ( path cfg -- )
annotate-gvn [
{ value-numbering } passes [
0 iteration [ watch-cfg ] with-variable
] with-variable
- ] [ reset-gvn ] [ ] cleanup ;
+ ] [ reset-gvn ] finally ;
: watch-gvn-bb ( path insns -- )
0 test-bb 0 get block>cfg watch-gvn-cfg ;
DESTRUCTOR: clean-up-context
: (with-cuda-context) ( context quot -- )
- swap '[ _ clean-up-context ] [ ] cleanup ; inline
+ swap '[ _ clean-up-context ] finally ; inline
: with-cuda-context ( device flags quot -- )
[ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline
DESTRUCTOR: free-resource
: with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
- over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
+ over [ map-resource ] 2dip '[ _ unmap-resource ] finally ; inline
TUPLE: cuda-buffer
{ buffer buffer }
init-colors
_ with-window
- ] [ ffi:endwin curses-error ] [ ] cleanup
+ ] [ ffi:endwin curses-error ] finally
] with-destructors ; inline
<PRIVATE
:: with-global-value ( value variable quot -- )
variable get-global "orig" [
[ value variable set-global quot call ]
- [ "orig" get variable set-global ] [ ] cleanup
+ [ "orig" get variable set-global ] finally
] with-variable ; inline
: preview-format-test ( format -- pass? )
graph dot-file ?encoding write-dot
dot-file format layout try-graphviz-command
]
- [ dot-file ?delete-file ] [ ] cleanup ;
+ [ dot-file ?delete-file ] finally ;
: graphviz* ( graph path format -- )
default-layout get-global graphviz ;
managed-server namespaces:set
[ handle-managed-client ]
[ cleanup-client ]
- [ ] cleanup ;
+ finally ;
: new-managed-server ( port name encoding class -- server )
new-threaded-server
] bi
notify-finish
finish-build
- ] [ cleanup-build ] [ ] cleanup
+ ] [ cleanup-build ] finally
notify-idle ;
MAIN: do-build
dup odbc-get-all-rows
swap odbc-free-statement
] keep
- ] [ odbc-disconnect ] [ ] cleanup ;
+ ] [ odbc-disconnect ] finally ;
] ; inline
: save-io-excursion ( quot -- )
- tell-input '[ _ seek-absolute seek-input ] [ ] cleanup ; inline
+ tell-input '[ _ seek-absolute seek-input ] finally ; inline
: consume-stream>sequence ( reader-quot: ( -- item ) -- seq )
until-eof-reader '[ drop @ ] t swap follow rest ; inline
projects / factor.git / commitdiff