cleanup some uses of current-directory.

locals-and-roots
John Benediktsson 2016-03-18 17:04:05 -07:00
parent e36727db23
commit 9c323e2884
11 changed files with 16 additions and 31 deletions

View File

@ -180,7 +180,7 @@ M: ftp-list handle-passive-command ( stream obj -- )
drop
start-directory [
utf8 encode-output [
current-directory get directory.
"." directory.
] with-string-writer string-lines
harvest [ ftp-send ] each
] with-output-stream finish-directory ;

View File

@ -198,7 +198,7 @@ $nl
io.pathnames tools.files sequences kernel ;
command-line get [
current-directory get directory.
\".\". directory.
] [
dup length 1 = [ first directory. ] [
[ [ nl write \":\" print ] [ directory. ] bi ] each

View File

@ -83,7 +83,7 @@ IN: io.launcher.unix
[ setup-process-group ] [ 2drop 249 _exit ] recover
[ setup-priority ] [ 2drop 250 _exit ] recover
[ setup-redirection ] [ 2drop 251 _exit ] recover
[ current-directory get absolute-path cd ] [ 2drop 252 _exit ] recover
[ "." absolute-path cd ] [ 2drop 252 _exit ] recover
[ setup-environment ] [ 2drop 253 _exit ] recover
[ get-arguments exec-args-with-path ] [ 2drop 254 _exit ] recover
255 _exit

View File

@ -60,14 +60,8 @@ ERROR: header-file-missing path ;
drop
] if* ;
:: read-local-include ( preprocessor-state path -- )
current-directory get path append-path dup :> full-path
dup exists? [
[ preprocessor-state ] dip preprocess-file
] [
! full-path header-file-missing
drop
] if ;
: read-local-include ( preprocessor-state path -- )
dup exists? [ preprocess-file ] [ 2drop ] if ;
: skip-whitespace/comments ( sequence-parser -- sequence-parser )
skip-whitespace

View File

@ -11,7 +11,7 @@ IN: file-monitor
"%u %s\n" printf flush file-monitor-loop ;
: file-monitor-main ( -- )
command-line get ?first current-directory get or
command-line get ?first "." or
dup "Monitoring %s\n" printf flush
[ t [ file-monitor-loop ] with-monitor ] with-monitors ;

View File

@ -28,8 +28,7 @@ IN: file-server
: file-server-main ( -- )
[
command-line get file-server-args
current-directory get or
command-line get file-server-args "." or
<static>
t >>allow-listings
swap [ enable-cgi ] when

View File

@ -40,8 +40,7 @@ SYMBOLS: supported-layouts supported-formats ;
! -O flag, so just look to see that there seems to be some sort
! of output.
: graphviz-output-appears-to-exist? ( base -- ? )
current-directory get directory-files
[ swap head? ] with count 1 = ;
"." directory-files [ swap head? ] with count 1 = ;
: next! ( seq -- elt ) [ first ] [ 1 rotate! ] bi ;

View File

@ -9,8 +9,7 @@ IN: mason.disk
: sufficient-disk-space? ( -- ? )
! We want at least 300Mb to be available before starting
! a build.
current-directory get file-system-info available-space>>
gb > ;
"." file-system-info available-space>> gb > ;
: check-disk-space ( -- )
sufficient-disk-space? [

View File

@ -50,8 +50,7 @@ IN: spotlight
PRIVATE>
: mdfind ( query -- results )
current-directory get "/" or swap
"mdfind -onlyin %s %s" sprintf run-process-output ;
"mdfind -onlyin . %s" sprintf run-process-output ;
: mdfind. ( query -- )
mdfind [ dup <pathname> write-object nl ] each ;

View File

@ -85,12 +85,9 @@ M: unknown-typeflag summary
: read/write-blocks ( header path -- )
binary [ read-data-blocks ] with-file-writer ;
: prepend-current-directory ( path -- path' )
current-directory get prepend-path ;
! Normal file
: typeflag-0 ( header -- )
dup name>> prepend-current-directory read/write-blocks ;
dup name>> read/write-blocks ;
TUPLE: hard-link linkname name ;
C: <hard-link> hard-link
@ -114,7 +111,7 @@ C: <symbolic-link> symbolic-link
! Directory
: typeflag-5 ( header -- )
name>> prepend-current-directory make-directories ;
name>> make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
@ -158,7 +155,7 @@ C: <symbolic-link> symbolic-link
;
! [ read-data-blocks ] with-string-writer
! [ zero? ] trim-tail filename set
! filename get prepend-current-directory make-directories ;
! filename get make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
@ -211,12 +208,10 @@ C: <symbolic-link> symbolic-link
GENERIC: do-link ( object -- )
M: hard-link do-link
[ linkname>> ]
[ name>> prepend-current-directory ] bi make-hard-link ;
[ linkname>> ] [ name>> ] bi make-hard-link ;
M: symbolic-link do-link
[ linkname>> ]
[ name>> prepend-current-directory ] bi make-link ;
[ linkname>> ] [ name>> ] bi make-link ;
! FIXME: linux tar calls unlinkat and makelinkat
: make-links ( -- )

View File

@ -52,7 +52,7 @@ DEFER: write-tree
: run-tree ( -- )
command-line get [
current-directory get tree
"." tree
] [
[ tree ] each
] if-empty ;