Conflicts:
	basis/opengl/debug/debug.factor
db4
Joe Groff 2009-10-28 19:30:20 -05:00
commit 9ae21ac5d9
27 changed files with 49 additions and 49 deletions

View File

@ -12,7 +12,7 @@ IN: compiler.tests.alien
<< <<
: libfactor-ffi-tests-path ( -- string ) : libfactor-ffi-tests-path ( -- string )
"resource:" (normalize-path) "resource:" absolute-path
{ {
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] } { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }

View File

@ -28,7 +28,7 @@ SYMBOL: edit-hook
require ; require ;
: edit-location ( file line -- ) : edit-location ( file line -- )
[ (normalize-path) ] dip edit-hook get-global [ absolute-path ] dip edit-hook get-global
[ call( file line -- ) ] [ no-edit-hook edit-location ] if* ; [ call( file line -- ) ] [ no-edit-hook edit-location ] if* ;
ERROR: cannot-find-source definition ; ERROR: cannot-find-source definition ;

View File

@ -11,7 +11,7 @@ IN: ftp.server.tests
: create-test-file ( -- path ) : create-test-file ( -- path )
test-file-contents test-file-contents
"ftp.server" "test" make-unique-file "ftp.server" "test" make-unique-file
[ ascii set-file-contents ] keep canonicalize-path ; [ ascii set-file-contents ] [ normalize-path ] bi ;
: test-ftp-server ( quot -- ) : test-ftp-server ( quot -- )
'[ '[

View File

@ -58,7 +58,7 @@ C: <ftp-disconnect> ftp-disconnect
send-response ; send-response ;
: serving? ( path -- ? ) : serving? ( path -- ? )
canonicalize-path server get serving-directory>> head? ; normalize-path server get serving-directory>> head? ;
: can-serve-directory? ( path -- ? ) : can-serve-directory? ( path -- ? )
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
@ -343,7 +343,7 @@ M: ftp-server handle-client* ( server -- )
: <ftp-server> ( directory port -- server ) : <ftp-server> ( directory port -- server )
latin1 ftp-server new-threaded-server latin1 ftp-server new-threaded-server
swap >>insecure swap >>insecure
swap canonicalize-path >>serving-directory swap normalize-path >>serving-directory
"ftp.server" >>name "ftp.server" >>name
5 minutes >>timeout ; 5 minutes >>timeout ;

View File

@ -9,7 +9,7 @@ IN: images.testing
<PRIVATE <PRIVATE
: fig-name ( path -- newpath ) : fig-name ( path -- newpath )
[ parent-directory canonicalize-path ] [ parent-directory normalize-path ]
[ file-stem ".fig" append ] bi [ file-stem ".fig" append ] bi
append-path ; append-path ;

View File

@ -119,7 +119,7 @@ ARTICLE: "current-directory" "Current working directory"
with-directory with-directory
} }
"This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" "This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
{ $subsections (normalize-path) } { $subsections absolute-path }
"The second is to change the working directory of the current process:" "The second is to change the working directory of the current process:"
{ $subsections { $subsections
cd cd

View File

@ -6,10 +6,10 @@ sequences system vocabs.loader fry ;
IN: io.directories IN: io.directories
: set-current-directory ( path -- ) : set-current-directory ( path -- )
(normalize-path) current-directory set ; absolute-path current-directory set ;
: with-directory ( path quot -- ) : with-directory ( path quot -- )
[ (normalize-path) current-directory ] dip with-variable ; inline [ absolute-path current-directory ] dip with-variable ; inline
! Creating directories ! Creating directories
HOOK: make-directory io-backend ( path -- ) HOOK: make-directory io-backend ( path -- )

View File

@ -6,11 +6,11 @@ locals math sequences sorting system unicode.case vocabs.loader ;
IN: io.directories.search IN: io.directories.search
: qualified-directory-entries ( path -- seq ) : qualified-directory-entries ( path -- seq )
(normalize-path) absolute-path
dup directory-entries [ [ append-path ] change-name ] with map ; dup directory-entries [ [ append-path ] change-name ] with map ;
: qualified-directory-files ( path -- seq ) : qualified-directory-files ( path -- seq )
(normalize-path) absolute-path
dup directory-files [ append-path ] with map ; dup directory-files [ append-path ] with map ;
: with-qualified-directory-files ( path quot -- ) : with-qualified-directory-files ( path quot -- )

View File

@ -80,7 +80,7 @@ M: linux file-systems
] if ; ] if ;
: find-mount-point ( path -- mtab-entry ) : find-mount-point ( path -- mtab-entry )
canonicalize-path resolve-symlinks
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ; ERROR: file-system-not-found ;

View File

@ -13,6 +13,6 @@ M: unix make-hard-link ( path1 path2 -- )
M: unix read-link ( path -- path' ) M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ; normalize-path read-symbolic-link ;
M: unix canonicalize-path ( path -- path' ) M: unix resolve-symlinks ( path -- path' )
path-components "/" path-components "/"
[ append-path dup exists? [ follow-links ] when ] reduce ; [ append-path dup exists? [ follow-links ] when ] reduce ;

View File

@ -38,7 +38,7 @@ M: winnt root-directory? ( path -- ? )
TR: normalize-separators "/" "\\" ; TR: normalize-separators "/" "\\" ;
M: winnt normalize-path ( string -- string' ) M: winnt normalize-path ( string -- string' )
(normalize-path) absolute-path
normalize-separators normalize-separators
prepend-prefix ; prepend-prefix ;

View File

@ -71,7 +71,7 @@ IN: io.launcher.unix
: spawn-process ( process -- * ) : spawn-process ( process -- * )
[ setup-priority ] [ 250 _exit ] recover [ setup-priority ] [ 250 _exit ] recover
[ setup-redirection ] [ 251 _exit ] recover [ setup-redirection ] [ 251 _exit ] recover
[ current-directory get (normalize-path) cd ] [ 252 _exit ] recover [ current-directory get absolute-path cd ] [ 252 _exit ] recover
[ setup-environment ] [ 253 _exit ] recover [ setup-environment ] [ 253 _exit ] recover
[ get-arguments exec-args-with-path ] [ 254 _exit ] recover [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
255 _exit ; 255 _exit ;

View File

@ -129,7 +129,7 @@ M: windows current-process-handle ( -- handle )
M: windows run-process* ( process -- handle ) M: windows run-process* ( process -- handle )
[ [
current-directory get (normalize-path) cd current-directory get absolute-path cd
dup make-CreateProcess-args dup make-CreateProcess-args
tuck fill-redirection tuck fill-redirection

View File

@ -36,7 +36,7 @@ TUPLE: linux-monitor < monitor wd inotify watches ;
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ; inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
: add-watch ( path mask mailbox -- monitor ) : add-watch ( path mask mailbox -- monitor )
[ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip [ [ absolute-path ] dip [ (add-watch) ] [ drop ] 2bi ] dip
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ; <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
: check-inotify ( -- ) : check-inotify ( -- )

View File

@ -95,7 +95,7 @@ M: recursive-monitor dispose*
ready>> ?promise ?linked drop ; ready>> ?promise ?linked drop ;
: <recursive-monitor> ( path mailbox -- monitor ) : <recursive-monitor> ( path mailbox -- monitor )
[ (normalize-path) ] dip [ absolute-path ] dip
recursive-monitor new-monitor recursive-monitor new-monitor
H{ } clone >>children H{ } clone >>children
<promise> >>ready <promise> >>ready

View File

@ -25,7 +25,7 @@ TUPLE: openssl-context < secure-context aliens sessions ;
: load-certificate-chain ( ctx -- ) : load-certificate-chain ( ctx -- )
dup config>> key-file>> [ dup config>> key-file>> [
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi [ handle>> ] [ config>> key-file>> absolute-path ] bi
SSL_CTX_use_certificate_chain_file SSL_CTX_use_certificate_chain_file
ssl-error ssl-error
] [ drop ] if ; ] [ drop ] if ;
@ -55,7 +55,7 @@ TUPLE: openssl-context < secure-context aliens sessions ;
: use-private-key-file ( ctx -- ) : use-private-key-file ( ctx -- )
dup config>> key-file>> [ dup config>> key-file>> [
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi [ handle>> ] [ config>> key-file>> absolute-path ] bi
SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
ssl-error ssl-error
] [ drop ] if ; ] [ drop ] if ;
@ -65,8 +65,8 @@ TUPLE: openssl-context < secure-context aliens sessions ;
[ handle>> ] [ handle>> ]
[ [
config>> config>>
[ ca-file>> dup [ (normalize-path) ] when ] [ ca-file>> dup [ absolute-path ] when ]
[ ca-path>> dup [ (normalize-path) ] when ] bi [ ca-path>> dup [ absolute-path ] when ] bi
] bi ] bi
SSL_CTX_load_verify_locations SSL_CTX_load_verify_locations
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ; ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;

View File

@ -163,7 +163,7 @@ M: local sockaddr-size drop sockaddr-un heap-size ;
M: local empty-sockaddr drop sockaddr-un <struct> ; M: local empty-sockaddr drop sockaddr-un <struct> ;
M: local make-sockaddr M: local make-sockaddr
path>> (normalize-path) path>> absolute-path
dup length 1 + max-un-path > [ "Path too long" throw ] when dup length 1 + max-un-path > [ "Path too long" throw ] when
sockaddr-un <struct> sockaddr-un <struct>
AF_UNIX >>family AF_UNIX >>family

View File

@ -88,7 +88,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
ALIAS: ShellExecute ShellExecuteW ALIAS: ShellExecute ShellExecuteW
: open-in-explorer ( dir -- ) : open-in-explorer ( dir -- )
[ f "open" ] dip (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ; [ f "open" ] dip absolute-path f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-directory ( n -- str ) : shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT f swap f SHGFP_TYPE_DEFAULT

View File

@ -101,15 +101,15 @@ HELP: normalize-path
} }
} ; } ;
HELP: (normalize-path) HELP: absolute-path
{ $values { $values
{ "path" "a pathname string" } { "path" "a pathname string" }
{ "path'" "a pathname string" } { "path'" "a pathname string" }
} }
{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " prefix, if present." } { $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " prefix, if present." }
{ $notes "On Windows NT platforms, this word does not prepend the Unicode path prefix." } ; { $notes "This word is exaclty the same as " { $link normalize-path } ", except on Windows NT platforms, where it does not prepend the Unicode path prefix. Most code should call " { $link normalize-path } " instead." } ;
HELP: canonicalize-path HELP: resolve-symlinks
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } } { $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Outputs a path where none of the path components are symlinks. This word is useful for determining the actual path on disk where a file is stored; the root of this absolute path is a mount point in the file-system." } { $description "Outputs a path where none of the path components are symlinks. This word is useful for determining the actual path on disk where a file is stored; the root of this absolute path is a mount point in the file-system." }
{ $notes "Most code should not need to call this word except in very special circumstances. One use case is finding the actual file-system on which a file is stored." } ; { $notes "Most code should not need to call this word except in very special circumstances. One use case is finding the actual file-system on which a file is stored." } ;
@ -150,11 +150,11 @@ ARTICLE: "io.pathnames" "Pathnames"
} }
"Literal pathnames:" "Literal pathnames:"
{ $subsections POSTPONE: P" } { $subsections POSTPONE: P" }
"Low-level words:" "Normalizing pathnames for use with native APIs:"
{ $subsections { $subsections normalize-path }
normalize-path "Outputting an absolute path from a path:"
(normalize-path) { $subsection absolute-path }
canonicalize-path "Removing symlinks from a path:"
} ; { $subsections resolve-symlinks } ;
ABOUT: "io.pathnames" ABOUT: "io.pathnames"

View File

@ -61,7 +61,7 @@ IN: io.pathnames.tests
"." current-directory set "." current-directory set
".." "resource-path" set ".." "resource-path" set
[ "../core/bootstrap/stage2.factor" ] [ "../core/bootstrap/stage2.factor" ]
[ "resource:core/bootstrap/stage2.factor" (normalize-path) ] [ "resource:core/bootstrap/stage2.factor" absolute-path ]
unit-test unit-test
] with-scope ] with-scope

View File

@ -127,38 +127,38 @@ PRIVATE>
: path-components ( path -- seq ) : path-components ( path -- seq )
normalize-path path-separator split harvest ; normalize-path path-separator split harvest ;
HOOK: canonicalize-path os ( path -- path' ) HOOK: resolve-symlinks os ( path -- path' )
M: object canonicalize-path normalize-path ; M: object resolve-symlinks normalize-path ;
: resource-path ( path -- newpath ) : resource-path ( path -- newpath )
"resource-path" get prepend-path ; "resource-path" get prepend-path ;
GENERIC: vocab-path ( path -- newpath ) GENERIC: vocab-path ( path -- newpath )
GENERIC: (normalize-path) ( path -- path' ) GENERIC: absolute-path ( path -- path' )
M: string (normalize-path) M: string absolute-path
"resource:" ?head [ "resource:" ?head [
trim-head-separators resource-path trim-head-separators resource-path
(normalize-path) absolute-path
] [ ] [
"vocab:" ?head [ "vocab:" ?head [
trim-head-separators vocab-path trim-head-separators vocab-path
(normalize-path) absolute-path
] [ ] [
current-directory get prepend-path current-directory get prepend-path
] if ] if
] if ; ] if ;
M: object normalize-path ( path -- path' ) M: object normalize-path ( path -- path' )
(normalize-path) ; absolute-path ;
TUPLE: pathname string ; TUPLE: pathname string ;
C: <pathname> pathname C: <pathname> pathname
M: pathname (normalize-path) string>> (normalize-path) ; M: pathname absolute-path string>> absolute-path ;
M: pathname <=> [ string>> ] compare ; M: pathname <=> [ string>> ] compare ;

View File

@ -139,11 +139,11 @@ PRIVATE>
: fuel-scaffold-vocab ( root name devname -- ) : fuel-scaffold-vocab ( root name devname -- )
[ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope [ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
dup require vocab-source-path (normalize-path) fuel-eval-set-result ; dup require vocab-source-path absolute-path fuel-eval-set-result ;
: fuel-scaffold-help ( name devname -- ) : fuel-scaffold-help ( name devname -- )
[ fuel-scaffold-name dup require dup scaffold-help ] with-scope [ fuel-scaffold-name dup require dup scaffold-help ] with-scope
vocab-docs-path (normalize-path) fuel-eval-set-result ; vocab-docs-path absolute-path fuel-eval-set-result ;
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ; : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;

View File

@ -11,7 +11,7 @@ IN: fuel.xref
<PRIVATE <PRIVATE
: normalize-loc ( seq -- path line ) : normalize-loc ( seq -- path line )
[ dup length 0 > [ first (normalize-path) ] [ drop f ] if ] [ dup length 0 > [ first absolute-path ] [ drop f ] if ]
[ dup length 1 > [ second ] [ drop 1 ] if ] bi ; [ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
: get-loc ( object -- loc ) normalize-loc 2array ; : get-loc ( object -- loc ) normalize-loc 2array ;

View File

@ -14,7 +14,7 @@ CONSTANT: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=down
: download-db ( -- path ) : download-db ( -- path )
db-path dup exists? [ db-path dup exists? [
db-url over ".gz" append download-to db-url over ".gz" append download-to
{ "gunzip" } over ".gz" append (normalize-path) suffix try-process { "gunzip" } over ".gz" append absolute-path suffix try-process
] unless ; ] unless ;
TUPLE: ip-entry from to registry assigned city cntry country ; TUPLE: ip-entry from to registry assigned city cntry country ;

View File

@ -23,7 +23,7 @@ HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree M: windows really-delete-tree
#! Workaround: Cygwin GIT creates read-only files for #! Workaround: Cygwin GIT creates read-only files for
#! some reason. #! some reason.
[ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix short-running-process ] [ { "chmod" "ug+rw" "-R" } swap absolute-path suffix short-running-process ]
[ delete-tree ] [ delete-tree ]
bi ; bi ;

View File

@ -65,7 +65,7 @@ CONSTANT: SOUND-WALK4 7
CONSTANT: SOUND-UFO-HIT 8 CONSTANT: SOUND-UFO-HIT 8
: init-sound ( index cpu filename -- ) : init-sound ( index cpu filename -- )
canonicalize-path swapd [ sounds>> nth AL_BUFFER ] dip absolte-path swapd [ sounds>> nth AL_BUFFER ] dip
create-buffer-from-wav set-source-param ; create-buffer-from-wav set-source-param ;
: init-sounds ( cpu -- ) : init-sounds ( cpu -- )

View File

@ -3,7 +3,7 @@
# change directories to a factor module # change directories to a factor module
function cdfactor { function cdfactor {
code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; " code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; "
printf "\"%s\" <vocab> vocab-source-path (normalize-path) print" $1) printf "\"%s\" <vocab> vocab-source-path absolute-path print" $1)
echo $code > $HOME/.cdfactor echo $code > $HOME/.cdfactor
fn=$(factor $HOME/.cdfactor) fn=$(factor $HOME/.cdfactor)
dn=$(dirname $fn) dn=$(dirname $fn)