continuations[-docs]: add the finally word
parent
4d5548d62d
commit
0007789795
|
@ -60,7 +60,7 @@ C: <connection> connection
|
|||
[ 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 ;
|
||||
|
|
|
@ -27,7 +27,7 @@ TUPLE: lock threads owner reentrant? ;
|
|||
|
||||
:: 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
|
||||
|
|
|
@ -32,7 +32,7 @@ M: negative-count-semaphore summary
|
|||
|
||||
:: 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
|
||||
|
|
|
@ -48,7 +48,7 @@ GENERIC: eval-generator ( singleton -- object )
|
|||
|
||||
: with-disposals ( object quotation -- )
|
||||
over sequence? [
|
||||
over '[ _ dispose-each ] [ ] cleanup
|
||||
over '[ _ dispose-each ] finally
|
||||
] [
|
||||
with-disposal
|
||||
] if ; inline
|
||||
|
|
|
@ -27,7 +27,7 @@ HOOK: set-os-envs-pointer os ( malloc -- )
|
|||
|
||||
: 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 ] }
|
||||
|
|
|
@ -59,7 +59,7 @@ ERROR: game-input-not-open ;
|
|||
] 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 ;
|
||||
|
|
|
@ -10,4 +10,4 @@ M: wrapped-hash-set >pprint-sequence members ;
|
|||
|
||||
M: wrapped-hash-set pprint*
|
||||
nesting-limit inc
|
||||
[ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
|
||||
[ pprint-object ] [ nesting-limit dec ] finally ;
|
||||
|
|
|
@ -10,4 +10,4 @@ M: wrapped-hashtable >pprint-sequence >alist ;
|
|||
|
||||
M: wrapped-hashtable pprint*
|
||||
nesting-limit inc
|
||||
[ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
|
||||
[ pprint-object ] [ nesting-limit dec ] finally ;
|
||||
|
|
|
@ -42,7 +42,7 @@ M: unix copy-file ( from to -- )
|
|||
: 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 )
|
||||
|
|
|
@ -84,4 +84,4 @@ M: windows (directory-entries) ( path -- seq )
|
|||
produce nip
|
||||
over name>> "." = [ nip ] [ swap prefix ] if
|
||||
]
|
||||
] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi [ ] cleanup ;
|
||||
] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi finally ;
|
||||
|
|
|
@ -194,7 +194,7 @@ CONSTANT: names-buf-length 16384
|
|||
[ _ 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
|
||||
|
|
|
@ -50,11 +50,11 @@ PRIVATE>
|
|||
|
||||
:: 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 )
|
||||
[
|
||||
|
@ -70,7 +70,7 @@ PRIVATE>
|
|||
:: 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" ] }
|
||||
|
|
|
@ -16,7 +16,7 @@ M: object dispose-monitors ;
|
|||
: with-monitors ( quot -- )
|
||||
[
|
||||
init-monitors
|
||||
[ dispose-monitors ] [ ] cleanup
|
||||
[ dispose-monitors ] finally
|
||||
] with-scope ; inline
|
||||
|
||||
TUPLE: monitor < disposable path queue timeout ;
|
||||
|
|
|
@ -211,7 +211,7 @@ PRIVATE>
|
|||
'[
|
||||
[ _ threaded-server _ with-variable ]
|
||||
[ _ stop-server ]
|
||||
[ ] cleanup
|
||||
finally
|
||||
] call ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -33,7 +33,7 @@ SYMBOL: handle-ctrl-break
|
|||
! 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 ;
|
||||
|
|
|
@ -33,7 +33,7 @@ SYMBOL: log-files
|
|||
[ 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 ;
|
||||
|
|
|
@ -134,14 +134,14 @@ PRIVATE>
|
|||
:: 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
|
||||
|
@ -150,7 +150,7 @@ PRIVATE>
|
|||
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
|
||||
|
|
|
@ -68,7 +68,7 @@ GENERIC: model-changed ( model observer -- )
|
|||
: with-locked-model ( model quot -- )
|
||||
[ '[ _ t >>locked? @ ] ]
|
||||
[ drop '[ f _ locked?<< ] ]
|
||||
2bi [ ] cleanup ; inline
|
||||
2bi finally ; inline
|
||||
|
||||
GENERIC: update-model ( model -- )
|
||||
|
||||
|
|
|
@ -37,7 +37,7 @@ IN: opengl.framebuffers
|
|||
|
||||
: 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 -- )
|
||||
[
|
||||
|
@ -47,7 +47,7 @@ IN: opengl.framebuffers
|
|||
[
|
||||
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
|
||||
|
|
|
@ -174,7 +174,7 @@ MACRO: all-enabled-client-state ( seq quot -- quot )
|
|||
|
||||
:: 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 '[
|
||||
|
@ -189,7 +189,7 @@ MACRO: all-enabled-client-state ( seq quot -- quot )
|
|||
|
||||
:: 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 [
|
||||
|
|
|
@ -114,7 +114,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
|
|||
] 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?) ;
|
||||
|
||||
|
|
|
@ -266,7 +266,7 @@ M: byte-vector pprint* pprint-object ;
|
|||
|
||||
: 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 ;
|
||||
|
|
|
@ -246,7 +246,7 @@ DEFER: blah4
|
|||
! 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
|
||||
|
|
|
@ -126,7 +126,7 @@ PRIVATE>
|
|||
_
|
||||
[ coverage-on test-vocab coverage-off ]
|
||||
[ coverage ] bi
|
||||
] [ _ remove-coverage ] [ ] cleanup
|
||||
] [ _ remove-coverage ] finally
|
||||
] call
|
||||
] bi ;
|
||||
|
||||
|
|
|
@ -47,7 +47,7 @@ PRIVATE>
|
|||
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 -- )
|
||||
|
|
|
@ -30,7 +30,7 @@ PRIVATE>
|
|||
: 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 ;
|
||||
|
|
|
@ -80,7 +80,7 @@ M: gtk-clipboard set-clipboard-contents
|
|||
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
|
||||
|
||||
|
|
|
@ -48,4 +48,4 @@ CONSTANT: poll-fd-events
|
|||
[
|
||||
source g_source_destroy
|
||||
start-io-thread
|
||||
] [ ] cleanup ;
|
||||
] finally ;
|
||||
|
|
|
@ -704,7 +704,7 @@ M: windows-ui-backend (with-ui)
|
|||
init-win32-ui
|
||||
start-ui
|
||||
event-loop
|
||||
] [ cleanup-win32-ui ] [ ] cleanup ;
|
||||
] [ cleanup-win32-ui ] finally ;
|
||||
|
||||
M: windows-ui-backend beep
|
||||
0 MessageBeep drop ;
|
||||
|
|
|
@ -228,7 +228,7 @@ M: object resize-window 2drop ;
|
|||
f ui-running set-global
|
||||
! Give running ui threads a chance to finish.
|
||||
notify-ui-thread yield
|
||||
] [ ] cleanup
|
||||
] finally
|
||||
] if ;
|
||||
|
||||
HOOK: beep ui-backend ( -- )
|
||||
|
|
|
@ -115,14 +115,14 @@ GENERIC: set-effective-group ( obj -- )
|
|||
|
||||
: (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
|
||||
|
|
|
@ -23,7 +23,7 @@ test-sigusr1-handler SIGUSR1 add-signal-handler
|
|||
swap -
|
||||
] unit-test
|
||||
|
||||
] [ test-sigusr1-handler SIGUSR1 remove-signal-handler ] [ ] cleanup
|
||||
] [ test-sigusr1-handler SIGUSR1 remove-signal-handler ] finally
|
||||
|
||||
{ 0 } [
|
||||
sigusr1-count get-global
|
||||
|
|
|
@ -32,7 +32,7 @@ M: unix passwd>new-passwd ( passwd -- seq )
|
|||
|
||||
: with-pwent ( quot -- )
|
||||
setpwent
|
||||
[ unix.ffi:endpwent ] [ ] cleanup ; inline
|
||||
[ unix.ffi:endpwent ] finally ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -94,7 +94,7 @@ GENERIC: set-effective-user ( string/id -- )
|
|||
: (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
|
||||
|
@ -102,7 +102,7 @@ GENERIC: set-effective-user ( string/id -- )
|
|||
: (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
|
||||
|
|
|
@ -38,7 +38,7 @@ M: unix new-utmpx-record
|
|||
utmpx-record new ;
|
||||
|
||||
: with-utmpx ( quot -- )
|
||||
setutxent [ endutxent ] [ ] cleanup ; inline
|
||||
setutxent [ endutxent ] finally ; inline
|
||||
|
||||
: all-utmpx ( -- seq )
|
||||
[
|
||||
|
|
|
@ -4,5 +4,5 @@ USING: vocabs.refresh tools.test continuations namespaces ;
|
|||
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
|
||||
|
|
|
@ -111,6 +111,6 @@ ERROR: null-com-release ;
|
|||
[ 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
|
||||
|
|
|
@ -25,7 +25,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
|||
! 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>
|
||||
|
@ -52,4 +52,4 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
|||
: with-privileges ( seq quot -- )
|
||||
[ '[ _ [ t set-privilege ] each @ ] ]
|
||||
[ drop '[ _ [ f set-privilege ] each ] ]
|
||||
2bi [ ] cleanup ; inline
|
||||
2bi finally ; inline
|
||||
|
|
|
@ -55,13 +55,13 @@ CONSTANT: registry-value-max-length 16384
|
|||
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
|
||||
|
||||
|
|
|
@ -31,6 +31,6 @@ SYMBOL: root
|
|||
: 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
|
||||
|
|
|
@ -21,7 +21,7 @@ SYMBOL: xim
|
|||
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 )
|
||||
[
|
||||
|
|
|
@ -131,7 +131,7 @@ PRIVATE>
|
|||
[ 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?
|
||||
|
|
|
@ -198,7 +198,7 @@ PRIVATE>
|
|||
[
|
||||
remove-nesting-observer
|
||||
finish-compilation-unit
|
||||
] [ ] cleanup
|
||||
] finally
|
||||
] with-variables ; inline
|
||||
|
||||
: with-compilation-unit ( quot -- )
|
||||
|
|
|
@ -169,12 +169,16 @@ HELP: throw
|
|||
{ $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." } ;
|
||||
|
|
|
@ -162,6 +162,9 @@ callback-error-hook [ [ die rethrow ] ] initialize
|
|||
: 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 )
|
||||
|
|
|
@ -59,7 +59,7 @@ M: disposable dispose
|
|||
[ last rethrow ] unless-empty ;
|
||||
|
||||
: with-disposal ( object quot -- )
|
||||
over [ dispose ] curry [ ] cleanup ; inline
|
||||
over [ dispose ] curry finally ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
@ -77,7 +77,7 @@ ERROR: can't-nest-definitions word ;
|
|||
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 )
|
||||
[
|
||||
|
|
|
@ -274,7 +274,7 @@ CONSTANT: pt-array-1
|
|||
[
|
||||
"resource:core" normalize-path
|
||||
[ cwd = ] [ cd ] [ cwd = ] tri
|
||||
] cwd '[ _ dup cd cwd = ] [ ] cleanup
|
||||
] cwd '[ _ dup cd cwd = ] finally
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
|
|
|
@ -93,14 +93,14 @@ SYMBOL: iteration
|
|||
] 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 ;
|
||||
|
|
|
@ -28,7 +28,7 @@ DESTRUCTOR: destroy-context
|
|||
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
|
||||
|
|
|
@ -39,7 +39,7 @@ DESTRUCTOR: unmap-resource
|
|||
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 }
|
||||
|
|
|
@ -277,7 +277,7 @@ PRIVATE>
|
|||
init-colors
|
||||
|
||||
_ with-window
|
||||
] [ ffi:endwin curses-error ] [ ] cleanup
|
||||
] [ ffi:endwin curses-error ] finally
|
||||
] with-destructors ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -232,7 +232,7 @@ SYMBOLS: supported-layouts supported-formats ;
|
|||
:: 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? )
|
||||
|
|
|
@ -82,7 +82,7 @@ PRIVATE>
|
|||
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 ;
|
||||
|
|
|
@ -95,7 +95,7 @@ M: managed-server handle-client*
|
|||
managed-server namespaces:set
|
||||
[ handle-managed-client ]
|
||||
[ cleanup-client ]
|
||||
[ ] cleanup ;
|
||||
finally ;
|
||||
|
||||
: new-managed-server ( port name encoding class -- server )
|
||||
new-threaded-server
|
||||
|
|
|
@ -48,7 +48,7 @@ IN: mason.build
|
|||
] bi
|
||||
notify-finish
|
||||
finish-build
|
||||
] [ cleanup-build ] [ ] cleanup
|
||||
] [ cleanup-build ] finally
|
||||
notify-idle ;
|
||||
|
||||
MAIN: do-build
|
||||
|
|
|
@ -279,4 +279,4 @@ C: <field> field
|
|||
dup odbc-get-all-rows
|
||||
swap odbc-free-statement
|
||||
] keep
|
||||
] [ odbc-disconnect ] [ ] cleanup ;
|
||||
] [ odbc-disconnect ] finally ;
|
||||
|
|
|
@ -29,7 +29,7 @@ IN: tools.image-analyzer.utils
|
|||
] ; 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
|
||||
|
|
Loading…
Reference in New Issue