diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7e90d8dd0..fb5923382e 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -43,6 +43,7 @@ IN: bootstrap.syntax "PRIMITIVE:" "PRIVATE>" "SBUF\"" + "SINGLETON:" "SYMBOL:" "TUPLE:" "T{" diff --git a/extra/classes/singleton/authors.txt b/core/classes/singleton/authors.txt similarity index 100% rename from extra/classes/singleton/authors.txt rename to core/classes/singleton/authors.txt diff --git a/extra/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor similarity index 100% rename from extra/classes/singleton/singleton-docs.factor rename to core/classes/singleton/singleton-docs.factor diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor new file mode 100644 index 0000000000..2ed51abb93 --- /dev/null +++ b/core/classes/singleton/singleton-tests.factor @@ -0,0 +1,12 @@ +USING: kernel classes.singleton tools.test prettyprint io.streams.string ; +IN: classes.singleton.tests + +[ ] [ SINGLETON: bzzt ] unit-test +[ t ] [ bzzt bzzt? ] unit-test +[ t ] [ bzzt bzzt eq? ] unit-test +GENERIC: zammo ( obj -- str ) +[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test +[ "yes!" ] [ bzzt zammo ] unit-test +[ ] [ SINGLETON: omg ] unit-test +[ t ] [ omg singleton-class? ] unit-test +[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor new file mode 100755 index 0000000000..65d7422ed7 --- /dev/null +++ b/core/classes/singleton/singleton.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes.predicate kernel sequences words ; +IN: classes.singleton + +PREDICATE: singleton-class < predicate-class + [ "predicate-definition" word-prop ] + [ [ eq? ] curry ] bi sequence= ; + +: define-singleton-class ( word -- ) + \ word over [ eq? ] curry define-predicate-class ; diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor old mode 100644 new mode 100755 index 04f34068eb..c3d7e8e89b --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.tests -USING: tools.test io.backend kernel ; - -[ ] [ "a" normalize-pathname drop ] unit-test +IN: io.backend.tests +USING: tools.test io.backend kernel ; + +[ ] [ "a" normalize-path drop ] unit-test diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 6bcd448385..44b1eea349 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs ; +io.encodings.utf8 init assocs splitting ; IN: io.backend SYMBOL: io-backend @@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- ) HOOK: normalize-directory io-backend ( str -- newstr ) -HOOK: normalize-pathname io-backend ( str -- newstr ) +HOOK: normalize-path io-backend ( str -- newstr ) -M: object normalize-directory normalize-pathname ; +M: object normalize-directory normalize-path ; : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1953569223..342967acfc 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -252,7 +252,7 @@ HELP: normalize-directory { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ; -HELP: normalize-pathname +HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 9920d8d25c..b4a7d44433 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -220,8 +220,6 @@ io.encodings.utf8 ; [ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test [ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test -[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test -[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test [ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test [ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test [ "/lib" ] [ "/usr" "../lib" append-path ] unit-test @@ -239,9 +237,6 @@ io.encodings.utf8 ; [ "lib" ] [ "" "lib" append-path ] unit-test [ "lib" ] [ "" "./lib" append-path ] unit-test -[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test -[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test - [ "foo/bar/." parent-directory ] must-fail [ "foo/bar/./" parent-directory ] must-fail [ "foo/bar/baz/.." parent-directory ] must-fail @@ -263,5 +258,4 @@ io.encodings.utf8 ; [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test [ t ] [ "resource:core" absolute-path? ] unit-test -[ t ] [ "/foo" absolute-path? ] unit-test [ f ] [ "" absolute-path? ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 099acb157e..720894d489 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream ) HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) - swap normalize-pathname (file-reader) swap ; + swap normalize-path (file-reader) swap ; : ( path encoding -- stream ) - swap normalize-pathname (file-writer) swap ; + swap normalize-path (file-writer) swap ; : ( path encoding -- stream ) - swap normalize-pathname (file-appender) swap ; + swap normalize-path (file-appender) swap ; : file-lines ( path encoding -- seq ) lines ; @@ -102,6 +102,7 @@ PRIVATE> : windows-absolute-path? ( path -- path ? ) { + { [ dup "\\\\?\\" head? ] [ t ] } { [ dup length 2 < ] [ f ] } { [ dup second CHAR: : = ] [ t ] } { [ t ] [ f ] } @@ -111,8 +112,8 @@ PRIVATE> { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } - { [ dup first path-separator? ] [ t ] } { [ windows? ] [ windows-absolute-path? ] } + { [ dup first path-separator? ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -126,6 +127,9 @@ PRIVATE> 2 tail left-trim-separators >r parent-directory r> append-path ] } + { [ over absolute-path? over first path-separator? and ] [ + >r 2 head r> append + ] } { [ t ] [ >r right-trim-separators "/" r> left-trim-separators 3append @@ -167,7 +171,7 @@ SYMBOL: +unknown+ ! File metadata : exists? ( path -- ? ) - normalize-pathname (exists?) ; + normalize-path (exists?) ; : directory? ( path -- ? ) file-info file-info-type +directory+ = ; @@ -183,18 +187,33 @@ M: object cwd ( -- path ) "." ; [ cwd current-directory set-global ] "io.files" add-init-hook +: resource-path ( path -- newpath ) + "resource-path" get [ image parent-directory ] unless* + prepend-path ; + +: (normalize-path) ( path -- path' ) + "resource:" ?head [ + left-trim-separators resource-path + (normalize-path) + ] [ + current-directory get prepend-path + ] if ; + +M: object normalize-path ( path -- path' ) + (normalize-path) ; + : with-directory ( path quot -- ) - >r normalize-pathname r> + >r (normalize-path) r> current-directory swap with-variable ; inline : set-current-directory ( path -- ) - normalize-pathname current-directory set ; + normalize-path current-directory set ; ! Creating directories HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) - normalize-pathname right-trim-separators { + normalize-path right-trim-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } @@ -267,7 +286,7 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - normalize-pathname + normalize-path over link-info type>> { { +symbolic-link+ [ copy-link ] } @@ -286,9 +305,6 @@ DEFER: copy-tree-into [ copy-tree-into ] curry each ; ! Special paths -: resource-path ( path -- newpath ) - "resource-path" get [ image parent-directory ] unless* - prepend-path ; : temp-directory ( -- path ) "temp" resource-path dup make-directories ; @@ -296,14 +312,6 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; -M: object normalize-pathname ( path -- path' ) - "resource:" ?head [ - left-trim-separators resource-path - normalize-pathname - ] [ - current-directory get prepend-path - ] if ; - ! Pathname presentations TUPLE: pathname string ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index d294f95be6..fd7133053a 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections prettyprint.config sorting splitting math.parser vocabs definitions effects classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.predicate -combinators quotations ; +classes.singleton combinators quotations ; : make-pprint ( obj quot -- block in use ) [ @@ -254,6 +254,9 @@ M: predicate-class see-class* "predicate-definition" word-prop pprint-elements pprint-; block> block> ; +M: singleton-class see-class* ( class -- ) + \ SINGLETON: pprint-word pprint-word ; + M: tuple-class see-class* ( path -- png ) - normalize-pathname + normalize-path cairo_image_surface_create_from_png dup cairo_surface_status cairo-png-error dup [ cairo_image_surface_get_width check-zero ] diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor deleted file mode 100644 index 453a2a0ea5..0000000000 --- a/extra/classes/singleton/singleton-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: kernel singleton tools.test prettyprint io.streams.string ; -IN: classes.singleton.tests - -[ ] [ SINGLETON: bzzt ] unit-test -[ t ] [ bzzt bzzt? ] unit-test -[ t ] [ bzzt bzzt eq? ] unit-test -GENERIC: zammo ( obj -- ) -[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test -[ "yes!" ] [ bzzt zammo ] unit-test -[ ] [ SINGLETON: omg ] unit-test -[ t ] [ omg singleton? ] unit-test -[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/extra/classes/singleton/singleton.factor b/extra/classes/singleton/singleton.factor deleted file mode 100755 index 61a519679c..0000000000 --- a/extra/classes/singleton/singleton.factor +++ /dev/null @@ -1,22 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.predicate kernel namespaces parser quotations -sequences words prettyprint prettyprint.backend prettyprint.sections -compiler.units classes ; -IN: classes.singleton - -PREDICATE: singleton < predicate-class - [ "predicate-definition" word-prop ] - [ [ eq? ] curry ] bi sequence= ; - -: define-singleton ( token -- ) - create-class-in - dup save-location - \ singleton - over [ eq? ] curry define-predicate-class ; - -: SINGLETON: - scan define-singleton ; parsing - -M: singleton see-class* ( class -- ) - r normalize-pathname "\\\\?\\" ?head drop r> + >r (normalize-path) "\\\\?\\" ?head drop r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) diff --git a/extra/editors/textwrangler/authors.txt b/extra/editors/textwrangler/authors.txt new file mode 100644 index 0000000000..b4a113da41 --- /dev/null +++ b/extra/editors/textwrangler/authors.txt @@ -0,0 +1 @@ +Ben Schlingelhof diff --git a/extra/editors/textwrangler/summary.txt b/extra/editors/textwrangler/summary.txt new file mode 100644 index 0000000000..cf502f96e5 --- /dev/null +++ b/extra/editors/textwrangler/summary.txt @@ -0,0 +1 @@ +Textwrangler editor integration diff --git a/extra/editors/textwrangler/textwrangler.factor b/extra/editors/textwrangler/textwrangler.factor new file mode 100644 index 0000000000..e97dadcdcb --- /dev/null +++ b/extra/editors/textwrangler/textwrangler.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Ben Schlingelhof. +! See http://factorcode.org/license.txt for BSD license. +USING: definitions io.launcher kernel parser words sequences +math math.parser namespaces editors ; +IN: editors.textwrangler + +: tw ( file line -- ) + [ "edit +" % # " " % % ] "" make run-process drop ; + +: tw-word ( word -- ) + where first2 tw ; + +[ tw ] edit-hook set-global diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index e1cc36cd2e..17799227b8 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -7,7 +7,7 @@ IN: io.sockets TUPLE: local path ; : ( path -- addrspec ) - normalize-pathname local construct-boa ; + normalize-path local construct-boa ; TUPLE: inet4 host port ; diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index bb2039adfb..040b191d27 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -21,3 +21,9 @@ IN: io.unix.files.tests [ "/lib/" ] [ "/" "../lib/" append-path ] unit-test [ "/lib" ] [ "/" "../../lib" append-path ] unit-test [ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test + +[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test +[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test +[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test +[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test +[ t ] [ "/foo" absolute-path? ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index c4e506d37f..7d0e7c4330 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -43,22 +43,22 @@ M: unix-io (file-appender) ( path -- stream ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable M: unix-io touch-file ( path -- ) - normalize-pathname + normalize-path touch-mode file-mode open dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when close ; M: unix-io move-file ( from to -- ) - [ normalize-pathname ] bi@ rename io-error ; + [ normalize-path ] bi@ rename io-error ; M: unix-io delete-file ( path -- ) - normalize-pathname unlink io-error ; + normalize-path unlink io-error ; M: unix-io make-directory ( path -- ) - normalize-pathname OCT: 777 mkdir io-error ; + normalize-path OCT: 777 mkdir io-error ; M: unix-io delete-directory ( path -- ) - normalize-pathname rmdir io-error ; + normalize-path rmdir io-error ; : (copy-file) ( from to -- ) dup parent-directory make-directories @@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ normalize-pathname ] bi@ + [ normalize-path ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] 2bi ; @@ -96,15 +96,15 @@ M: unix-io copy-file ( from to -- ) \ file-info construct-boa ; M: unix-io file-info ( path -- info ) - normalize-pathname stat* stat>file-info ; + normalize-path stat* stat>file-info ; M: unix-io link-info ( path -- info ) - normalize-pathname lstat* stat>file-info ; + normalize-path lstat* stat>file-info ; M: unix-io make-link ( path1 path2 -- ) - normalize-pathname symlink io-error ; + normalize-path symlink io-error ; M: unix-io read-link ( path -- path' ) - normalize-pathname + normalize-path PATH_MAX [ tuck ] [ ] bi readlink dup io-error head-slice >string ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index f738bd42c2..4986024e78 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -37,7 +37,7 @@ USE: unix 2nip reset-fd ; : redirect-file ( obj mode fd -- ) - >r >r normalize-pathname r> file-mode + >r >r normalize-path r> file-mode open dup io-error r> redirect-fd ; : redirect-closed ( obj mode fd -- ) diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index c4f5b2ef9e..1e5cedae57 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -4,7 +4,7 @@ prettyprint sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend ; IN: windows.ce.files -! M: windows-ce-io normalize-pathname ( string -- string ) +! M: windows-ce-io normalize-path ( string -- string ) ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; M: windows-ce-io CreateFile-flags ( DWORD -- DWORD ) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 295b3ab006..a23a78b3da 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -89,14 +89,14 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] if ; M: windows-nt-io file-info ( path -- info ) - normalize-pathname get-file-information-stat ; + normalize-path get-file-information-stat ; M: windows-nt-io link-info ( path -- info ) file-info ; : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-pathname open-existing dup close-always + normalize-path open-existing dup close-always "FILETIME" "FILETIME" "FILETIME" @@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-pathname open-existing dup close-always + normalize-path open-existing dup close-always r> r> r> (set-file-times) ] with-destructors ; @@ -127,7 +127,7 @@ M: windows-nt-io link-info ( path -- info ) M: windows-nt-io touch-file ( path -- ) [ - normalize-pathname + normalize-path maybe-create-file over close-always [ drop ] [ f now dup (set-file-times) ] if ] with-destructors ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 31247e43c3..579745710e 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -28,7 +28,7 @@ TUPLE: CreateProcess-args "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles 0 >>dwCreateFlags - current-directory get normalize-pathname >>lpCurrentDirectory ; + current-directory get (normalize-path) >>lpCurrentDirectory ; : call-CreateProcess ( CreateProcess-args -- ) { diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor old mode 100644 new mode 100755 index 73d6a0bf7f..1e6268fbc0 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -1,9 +1,9 @@ USING: io.files kernel tools.test io.backend -io.windows.nt.files splitting ; +io.windows.nt.files splitting sequences ; IN: io.windows.nt.files.tests -[ t ] [ "\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test +[ f ] [ "\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test [ t ] [ "c:\\foo" absolute-path? ] unit-test [ t ] [ "c:" absolute-path? ] unit-test @@ -29,19 +29,22 @@ IN: io.windows.nt.files.tests [ ] [ "" resource-path cd ] unit-test -[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test +[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ "C:\\builds\\factor\\12345\\" - "..\\log.txt" append-path normalize-pathname + "..\\log.txt" append-path normalize-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-pathname + "..\\.." append-path normalize-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-pathname + "..\\.." append-path normalize-path ] unit-test + +[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test +[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 81112a89c0..91ad0139b2 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -36,28 +36,14 @@ ERROR: not-absolute-path ; } && [ 2 head ] [ not-absolute-path ] if ; : prepend-prefix ( string -- string' ) - unicode-prefix prepend ; + dup unicode-prefix head? [ + unicode-prefix prepend + ] unless ; -ERROR: nonstring-pathname ; -ERROR: empty-pathname ; - -M: windows-nt-io normalize-pathname ( string -- string ) - "resource:" ?head [ - left-trim-separators resource-path - normalize-pathname - ] [ - dup empty? [ empty-pathname ] when - current-directory get prepend-path - dup unicode-prefix head? [ - dup first path-separator? [ - left-trim-separators - current-directory get 2 head - prepend-path - ] when - unicode-prefix prepend - ] unless - { { CHAR: / CHAR: \\ } } substitute ! necessary - ] if ; +M: windows-nt-io normalize-path ( string -- string' ) + (normalize-path) + { { CHAR: / CHAR: \\ } } substitute + prepend-prefix ; M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index c342b2ee9a..895890e898 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -32,7 +32,7 @@ IN: io.windows.nt.launcher drop 2nip null-pipe ; :: redirect-file ( default path access-mode create-mode -- handle ) - path normalize-pathname + path normalize-path access-mode share-mode security-attributes-inherit diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 27917cedfa..45c1adaf50 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -25,7 +25,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) M: windows-io normalize-directory ( string -- string ) - normalize-pathname "\\" ?tail drop "\\*" append ; + normalize-path "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) { @@ -135,21 +135,21 @@ M: windows-io (file-appender) ( path -- stream ) open-append ; M: windows-io move-file ( from to -- ) - [ normalize-pathname ] bi@ MoveFile win32-error=0/f ; + [ normalize-path ] bi@ MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) - normalize-pathname DeleteFile win32-error=0/f ; + normalize-path DeleteFile win32-error=0/f ; M: windows-io copy-file ( from to -- ) dup parent-directory make-directories - [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ; + [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; M: windows-io make-directory ( path -- ) - normalize-pathname + normalize-path f CreateDirectory win32-error=0/f ; M: windows-io delete-directory ( path -- ) - normalize-pathname + normalize-path RemoveDirectory win32-error=0/f ; HOOK: WSASocket-flags io-backend ( -- DWORD ) diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor deleted file mode 100644 index f073ccadd3..0000000000 --- a/extra/new-effects/new-effects.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: assocs kernel sequences ; -IN: new-effects - -: new-nth ( seq n -- elt ) - swap nth ; inline - -: new-set-nth ( seq obj n -- seq ) - pick set-nth ; inline - -: new-at ( assoc key -- elt ) - swap at ; inline - -: new-at* ( assoc key -- elt ? ) - swap at* ; inline - -: new-set-at ( assoc value key -- assoc ) - pick set-at ; inline diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index a5db87ca37..53cda66dfc 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -17,9 +17,16 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is ( seq i val -- seq ) swap pick set-nth ; +: nth-is ( seq i val -- seq ) swap pick set-nth ; +: is-nth ( seq val i -- seq ) pick set-nth ; -: is-nth ( seq val i -- seq ) pick set-nth ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mutate-nth ( seq i val -- ) swap rot set-nth ; +: mutate-at-nth ( seq val i -- ) rot set-nth ; + +: mutate-nth-of ( i val seq -- ) swapd set-nth ; +: mutate-at-nth-of ( val i seq -- ) set-nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -33,6 +40,14 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: mutate-key ( tbl key val -- ) swap rot set-at ; +: mutate-at-key ( tbl val key -- ) rot set-at ; + +: mutate-key-of ( key val tbl -- ) swapd set-at ; +: mutate-at-key-of ( val key tbl -- ) set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : push ( seq obj -- seq ) over sequences:push ; : push-on ( obj seq -- seq ) tuck sequences:push ; @@ -48,3 +63,6 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A note about the 'mutate' qualifier. Other words also technically mutate +! their primary object. However, the 'mutate' qualifier is supposed to +! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 8ddbdac6f4..77054ea377 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges random ; +accessors math.ranges random circular ; IN: random.mersenne-twister = [ - ] [ drop ] if ; inline -: mt-wrap ( x -- y ) mt-n wrap ; inline : set-generated ( y from-elt to seq -- ) >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi @@ -27,8 +25,8 @@ TUPLE: mersenne-twister seq i ; tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline : (mt-generate) ( n mt-seq -- y to from-elt ) - [ >r dup 1+ mt-wrap r> calculate-y ] - [ >r mt-m + mt-wrap r> nth ] + [ >r dup 1+ r> calculate-y ] + [ >r mt-m + r> nth ] [ drop ] 2tri ; : mt-generate ( mt -- ) @@ -36,7 +34,7 @@ TUPLE: mersenne-twister seq i ; [ 0 >>i drop ] bi ; : init-mt-first ( seed -- seq ) - >r mt-n 0 r> + >r mt-n 0 r> HEX: ffffffff bitand 0 pick set-nth ; : init-mt-formula ( seq i -- f(seq[i]) )