From a80e95ac2d65de8b96edfdbb638a06551cfbdf2b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 18:02:39 -0500
Subject: [PATCH 01/12] fix using
---
extra/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
index 453a2a0ea5..08f4a77aad 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -1,4 +1,4 @@
-USING: kernel singleton tools.test prettyprint io.streams.string ;
+USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
From ae623ff9249632872cc85c69ecf3ade2797a47d0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 19:00:20 -0500
Subject: [PATCH 02/12] normalize-pathname prepends unicode prefix,
(normalize-pathname) does not
---
core/io/backend/backend.factor | 2 +-
core/io/files/files-tests.factor | 6 -----
core/io/files/files.factor | 13 ++++++---
extra/editors/editors.factor | 2 +-
extra/io/unix/files/files-tests.factor | 6 +++++
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/files/files-tests.factor | 9 ++++---
extra/io/windows/nt/files/files.factor | 28 +++++---------------
8 files changed, 32 insertions(+), 36 deletions(-)
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 6bcd448385..935b007dd5 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
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..d2142cc6f3 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -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
@@ -296,14 +300,17 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
-M: object normalize-pathname ( path -- path' )
+: (normalize-pathname) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
- normalize-pathname
+ (normalize-pathname)
] [
current-directory get prepend-path
] if ;
+M: object normalize-pathname ( path -- path' )
+ (normalize-pathname) ;
+
! Pathname presentations
TUPLE: pathname string ;
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index c442dfaa94..00e20de5b5 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r normalize-pathname "\\\\?\\" ?head drop r>
+ >r (normalize-pathname) "\\\\?\\" ?head drop r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index bb2039adfb..a0310a1cac 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 ] }
+{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
+{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
+{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
+{ [ t ] [ "/foo" absolute-path? ] }
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 31247e43c3..f3226bfbf0 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags
- current-directory get normalize-pathname >>lpCurrentDirectory ;
+ current-directory get (normalize-pathname) >>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
index 73d6a0bf7f..431aced65d 100644
--- 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
@@ -45,3 +45,6 @@ IN: io.windows.nt.files.tests
"C:\\builds\\factor\\12345\\"
"..\\.." append-path normalize-pathname
] 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..bc676b8d0a 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-pathname ( string -- string' )
+ (normalize-pathname)
+ { { CHAR: / CHAR: \\ } } substitute
+ prepend-prefix ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
From 5ecb754cc863eca4f52e2d8a19edb20c78a8b85f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 18:18:18 -0600
Subject: [PATCH 03/12] newfx: mutators
---
extra/newfx/newfx.factor | 22 ++++++++++++++++++++--
1 file changed, 20 insertions(+), 2 deletions(-)
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
From 2bad7228a7df0496b240c2b4b5f7483b06b0d10e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 19:51:49 -0500
Subject: [PATCH 04/12] rename normalize-pathname to normalize-path fix windows
launcher issue
---
core/io/backend/backend-tests.factor | 8 ++--
core/io/backend/backend.factor | 4 +-
core/io/files/files-docs.factor | 2 +-
core/io/files/files.factor | 45 ++++++++++----------
extra/cairo/png/png.factor | 2 +-
extra/editors/editors.factor | 2 +-
extra/io/sockets/sockets.factor | 2 +-
extra/io/unix/files/files.factor | 20 ++++-----
extra/io/unix/launcher/launcher.factor | 2 +-
extra/io/windows/ce/files/files.factor | 2 +-
extra/io/windows/files/files.factor | 8 ++--
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/files/files-tests.factor | 8 ++--
extra/io/windows/nt/files/files.factor | 4 +-
extra/io/windows/nt/launcher/launcher.factor | 2 +-
extra/io/windows/windows.factor | 12 +++---
16 files changed, 63 insertions(+), 62 deletions(-)
mode change 100644 => 100755 core/io/backend/backend-tests.factor
mode change 100644 => 100755 extra/io/windows/nt/files/files-tests.factor
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 935b007dd5..44b1eea349 100755
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -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 <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index d2142cc6f3..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 )
: <file-reader> ( path encoding -- stream )
- swap normalize-pathname (file-reader) swap <decoder> ;
+ swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
- swap normalize-pathname (file-writer) swap <encoder> ;
+ swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
- swap normalize-pathname (file-appender) swap <encoder> ;
+ swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
@@ -171,7 +171,7 @@ SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
- normalize-pathname (exists?) ;
+ normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
@@ -187,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? ] [ ] }
@@ -271,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 ] }
@@ -290,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 ;
@@ -300,17 +312,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
-: (normalize-pathname) ( path -- path' )
- "resource:" ?head [
- left-trim-separators resource-path
- (normalize-pathname)
- ] [
- current-directory get prepend-path
- ] if ;
-
-M: object normalize-pathname ( path -- path' )
- (normalize-pathname) ;
-
! Pathname presentations
TUPLE: pathname string ;
diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
index 774a1afe8e..f9908e4581 100755
--- a/extra/cairo/png/png.factor
+++ b/extra/cairo/png/png.factor
@@ -24,7 +24,7 @@ ERROR: cairo-error string ;
} cond ;
: <png> ( 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/editors/editors.factor b/extra/editors/editors.factor
index 00e20de5b5..e871d5f808 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >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/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 ;
: <local> ( path -- addrspec )
- normalize-pathname local construct-boa ;
+ normalize-path local construct-boa ;
TUPLE: inet4 host port ;
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 [ <byte-array> 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" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
@@ -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 f3226bfbf0..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" <c-object> >>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 431aced65d..1e6268fbc0
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -29,21 +29,21 @@ 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
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index bc676b8d0a..91ad0139b2 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -40,8 +40,8 @@ ERROR: not-absolute-path ;
unicode-prefix prepend
] unless ;
-M: windows-nt-io normalize-pathname ( string -- string' )
- (normalize-pathname)
+M: windows-nt-io normalize-path ( string -- string' )
+ (normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
prepend-prefix ;
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 <win32-file> <writer> ;
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 )
From 8047115746ada0a5577e8e045140a8424441005b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 18:52:40 -0600
Subject: [PATCH 05/12] remove extra/new-effects
---
extra/new-effects/new-effects.factor | 17 -----------------
1 file changed, 17 deletions(-)
delete mode 100644 extra/new-effects/new-effects.factor
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
From a94e5245a3b35d6062990729e16b8bf13d2a4cdd Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Tue, 1 Apr 2008 20:07:18 -0500
Subject: [PATCH 06/12] fix teh tests FOR GREAT JUSTICE
---
extra/io/unix/files/files-tests.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index a0310a1cac..040b191d27 100755
--- a/extra/io/unix/files/files-tests.factor
+++ b/extra/io/unix/files/files-tests.factor
@@ -22,8 +22,8 @@ IN: io.unix.files.tests
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
-{ [ "/lib" ] [ "/usr/" "/lib" append-path ] }
-{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
-{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
-{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
-{ [ t ] [ "/foo" absolute-path? ] }
+[ "/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
From 6ac0d4692fee4a81fef062a9738f1030abee6ae6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 20:20:13 -0500
Subject: [PATCH 07/12] remove wrap word, add circular to mersenne twister
---
extra/random/mersenne-twister/mersenne-twister.factor | 10 ++++------
1 file changed, 4 insertions(+), 6 deletions(-)
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
<PRIVATE
@@ -16,8 +16,6 @@ TUPLE: mersenne-twister seq i ;
: mt-a HEX: 9908b0df ; inline
: mt-hi HEX: 80000000 bitand ; inline
: mt-lo HEX: 7fffffff bitand ; inline
-: wrap ( x n -- y ) 2dup >= [ - ] [ 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 <array> r>
+ >r mt-n 0 <array> <circular> r>
HEX: ffffffff bitand 0 pick set-nth ;
: init-mt-formula ( seq i -- f(seq[i]) )
From b085ce2f5ff236eeae7640fcd75c34a189648cab Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Tue, 1 Apr 2008 22:24:00 -0500
Subject: [PATCH 08/12] fix unit test
---
extra/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
index 08f4a77aad..586724ee3b 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "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
+[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
From 11feb563ebdb1ca453ac1d96e8391a9b07478bf1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 13:11:55 -0500
Subject: [PATCH 09/12] move singletons to core
---
core/bootstrap/syntax.factor | 1 +
{extra => core}/classes/singleton/authors.txt | 0
{extra => core}/classes/singleton/singleton-docs.factor | 0
{extra => core}/classes/singleton/singleton-tests.factor | 2 +-
{extra => core}/classes/singleton/singleton.factor | 3 ---
core/syntax/syntax.factor | 6 +++++-
6 files changed, 7 insertions(+), 5 deletions(-)
rename {extra => core}/classes/singleton/authors.txt (100%)
rename {extra => core}/classes/singleton/singleton-docs.factor (100%)
rename {extra => core}/classes/singleton/singleton-tests.factor (75%)
rename {extra => core}/classes/singleton/singleton.factor (92%)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e7e90d8dd0..e5a439c32b 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -43,6 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
+ "SINLETON:"
"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/extra/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
similarity index 75%
rename from extra/classes/singleton/singleton-tests.factor
rename to core/classes/singleton/singleton-tests.factor
index 586724ee3b..11a2a2d166 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
similarity index 92%
rename from extra/classes/singleton/singleton.factor
rename to core/classes/singleton/singleton.factor
index 61a519679c..13fd242dad 100755
--- a/extra/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -15,8 +15,5 @@ PREDICATE: singleton < predicate-class
\ singleton
over [ eq? ] curry define-predicate-class ;
-: SINGLETON:
- scan define-singleton ; parsing
-
M: singleton see-class* ( class -- )
<colon \ SINGLETON: pprint-word pprint-word ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 19fdf0e45f..1191752ed7 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
-combinators debugger ;
+combinators debugger classes.singleton ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -154,6 +154,10 @@ IN: bootstrap.syntax
parse-definition define-predicate-class
] define-syntax
+ "SINGLETON:" [
+ scan define-singleton
+ ] define-syntax
+
"TUPLE:" [
parse-tuple-definition define-tuple-class
] define-syntax
From e62c3c323c99490e9e0aebfafaeabb1b9e3ed7d4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 13:13:56 -0500
Subject: [PATCH 10/12] fix unit test
---
core/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 11a2a2d166..92a9877477 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -4,7 +4,7 @@ IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
-GENERIC: zammo ( obj -- )
+GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
From c89ee5bfccfb8d6e19906841b3dd5fc06917b74c Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 15:11:11 -0500
Subject: [PATCH 11/12] add textwrangler binding
---
extra/editors/textwrangler/authors.txt | 1 +
extra/editors/textwrangler/summary.txt | 1 +
extra/editors/textwrangler/textwrangler.factor | 13 +++++++++++++
3 files changed, 15 insertions(+)
create mode 100644 extra/editors/textwrangler/authors.txt
create mode 100644 extra/editors/textwrangler/summary.txt
create mode 100644 extra/editors/textwrangler/textwrangler.factor
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
From 47b54b13072b91c4b3bdf2ecfb7673bd77aedaea Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 15:41:29 -0500
Subject: [PATCH 12/12] add singletons to core
---
core/bootstrap/syntax.factor | 2 +-
core/classes/singleton/singleton-tests.factor | 2 +-
core/classes/singleton/singleton.factor | 16 ++++------------
core/prettyprint/prettyprint.factor | 5 ++++-
core/syntax/syntax.factor | 7 ++++---
5 files changed, 14 insertions(+), 18 deletions(-)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e5a439c32b..fb5923382e 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -43,7 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
- "SINLETON:"
+ "SINGLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 92a9877477..2ed51abb93 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -8,5 +8,5 @@ GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
-[ t ] [ omg singleton? ] 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
index 13fd242dad..65d7422ed7 100755
--- a/core/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -1,19 +1,11 @@
! 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 ;
+USING: classes.predicate kernel sequences words ;
IN: classes.singleton
-PREDICATE: singleton < predicate-class
+PREDICATE: singleton-class < 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 ;
-
-M: singleton see-class* ( class -- )
- <colon \ SINGLETON: pprint-word pprint-word ;
+: define-singleton-class ( word -- )
+ \ word over [ eq? ] curry define-predicate-class ;
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*
<colon \ TUPLE: pprint-word
dup pprint-word
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 1191752ed7..90bb1f0a6d 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units
-combinators debugger classes.singleton ;
+classes.union classes.mixin classes.predicate classes.singleton
+compiler.units combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -155,7 +155,8 @@ IN: bootstrap.syntax
] define-syntax
"SINGLETON:" [
- scan define-singleton
+ scan create-class-in
+ dup save-location define-singleton-class
] define-syntax
"TUPLE:" [