From c45ccbbc24d3de0e27fccd645682a41cc8e05650 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 7 Apr 2007 12:39:10 -0500
Subject: [PATCH 001/197] special case netbsd64 gcc3-4
---
misc/factor.sh | 3 +++
1 file changed, 3 insertions(+)
diff --git a/misc/factor.sh b/misc/factor.sh
index 276956b0b7..9d4f26fa46 100755
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -88,6 +88,9 @@ set_md5sum() {
set_gcc() {
case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;;
+ netbsd) if [[ $WORD -eq 64 ]] ; then
+ CC=/usr/pkg/gcc34/bin/gcc
+ fi ;;
*) CC=gcc;;
esac
}
From f7ec7cbc441f26ca39bfe4029245d9fb23099db9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 15 Feb 2008 18:08:01 -0800
Subject: [PATCH 002/197] ole32.dll bindings
---
core/alien/alien-docs.factor | 18 ++++++++++-
core/alien/alien.factor | 10 +++++-
extra/opengl/shaders/shaders.factor | 9 +++---
extra/windows/ce/ce.factor | 1 +
extra/windows/com/com.factor | 8 +++++
extra/windows/com/syntax/syntax.factor | 26 ++++++++++++++++
extra/windows/nt/nt.factor | 1 +
extra/windows/ole32/ole32.factor | 43 ++++++++++++++++++++++++++
extra/windows/shell32/shell32.factor | 16 ++--------
9 files changed, 112 insertions(+), 20 deletions(-)
mode change 100644 => 100755 extra/opengl/shaders/shaders.factor
mode change 100644 => 100755 extra/windows/ce/ce.factor
create mode 100755 extra/windows/com/com.factor
create mode 100755 extra/windows/com/syntax/syntax.factor
mode change 100644 => 100755 extra/windows/nt/nt.factor
create mode 100755 extra/windows/ole32/ole32.factor
mode change 100644 => 100755 extra/windows/shell32/shell32.factor
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 19ee52b039..68509db37f 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -145,7 +145,23 @@ HELP: alien-callback
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
-{ alien-invoke alien-indirect alien-callback } related-words
+HELP: out-keep
+{ $values { "quot" "A quotation" } { "out-indexes" "A sequence of indexes relative to the top of the stack" } }
+{ $description
+ "Invokes " { $snippet "quot" } ", restoring the values to the stack indicated by " { $snippet "out-indexes" } ". This word is useful for calling C functions with out parameters. " { $snippet "quot" } " can invoke the function and manipulate its return value, after which the actually interesting values stored in the out parameters are brought back to the top of the stack." }
+{ $notes "The indexes in " { $snippet "out-indexes" } " are relative to the top of the stack, with " { $snippet "1" } " indicating the topmost value. This means that the indexes are reversed relative to the order in the C prototype; 1 indicates the rightmost parameter, and higher numbers count leftward." }
+{ $examples
+ "A simple wrapper around memcpy (pretending that the return value is not equal to the out parameter):"
+ { $code
+ "LIBRARY: libc"
+ "FUNCTION: void* memcpy ( void* out, void* in, size_t n ) ;"
+ ": copy-byte-array ( a -- a' )"
+ " dup length dup <byte-array> -rot"
+ " [ memcpy drop ] { 3 } out-keep ;"
+ }
+} ;
+
+{ alien-invoke alien-indirect alien-callback out-keep } related-words
ARTICLE: "aliens" "Alien addresses"
"Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 317dac803e..b644846393 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
-kernel.private tuples bit-arrays byte-arrays float-arrays ;
+kernel.private tuples bit-arrays byte-arrays float-arrays
+shuffle arrays macros ;
IN: alien
! Some predicate classes used by the compiler for optimization
@@ -89,3 +90,10 @@ TUPLE: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
2over \ alien-invoke-error construct-boa throw ;
+
+MACRO: out-keep ( word out-indexes -- ... )
+ [
+ dup >r [ \ npick \ >r 3array % ] each
+ %
+ r> [ drop \ r> , ] each
+ ] [ ] make ;
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
old mode 100644
new mode 100755
index 0ff708d6d4..7755df6513
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -92,10 +92,11 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
GL_ATTACHED_SHADERS gl-program-get-int ; inline
: gl-program-shaders ( program -- shaders )
- dup gl-program-shaders-length [
- dup "GLuint" <c-array>
- [ 0 <int> swap glGetAttachedShaders ] keep
- ] keep c-uint-array> ;
+ dup gl-program-shaders-length
+ dup "GLuint" <c-array>
+ 0 <int> swap
+ [ glGetAttachedShaders ] { 3 1 } out-keep
+ c-uint-array> ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline
diff --git a/extra/windows/ce/ce.factor b/extra/windows/ce/ce.factor
old mode 100644
new mode 100755
index 1180d78a2b..948612b2b2
--- a/extra/windows/ce/ce.factor
+++ b/extra/windows/ce/ce.factor
@@ -11,4 +11,5 @@ USING: alien sequences ;
! { "gl" "libGLES_CM.dll" "stdcall" }
! { "glu" "libGLES_CM.dll" "stdcall" }
! { "freetype" "libfreetype-6.dll" "stdcall" }
+ { "ole32" "ole32.dll" "stdcall" }
} [ first3 add-library ] each
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
new file mode 100755
index 0000000000..9543ec7e6a
--- /dev/null
+++ b/extra/windows/com/com.factor
@@ -0,0 +1,8 @@
+USING: alien alien.c-types windows.com.syntax windows.ole32
+windows.types ;
+IN: windows.com
+
+COM-INTERFACE: IUnknown f
+ HRESULT QueryInterface ( void* this, REFGUID iid, void** ppvObject )
+ ULONG AddRef ( void* this )
+ ULONG Release ( void* this ) ;
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
new file mode 100755
index 0000000000..12258644ae
--- /dev/null
+++ b/extra/windows/com/syntax/syntax.factor
@@ -0,0 +1,26 @@
+USING: alien alien.c-types kernel windows windows.ole32
+combinators.lib parser splitting sequences.lib ;
+IN: windows.com.syntax
+
+<PRIVATE
+
+: vtbl ( interface -- vtbl )
+ *void* ; inline
+: com-invoke ( ... interface n funcptr return parameters -- )
+ "stdcall" [
+ swap vtbl swap void*-nth
+ ] 4 ndip alien-indirect ;
+
+: parse-inheritance
+ scan dup {
+ } case ;
+
+PRIVATE>
+
+: COM-INTERFACE:
+ scan
+ parse-inheritance
+ ";" parse-tokens { ")" } split
+ [
+ ; parsing
+
diff --git a/extra/windows/nt/nt.factor b/extra/windows/nt/nt.factor
old mode 100644
new mode 100755
index 8a709416d8..1dc997b38a
--- a/extra/windows/nt/nt.factor
+++ b/extra/windows/nt/nt.factor
@@ -12,4 +12,5 @@ USING: alien sequences ;
{ "gl" "opengl32.dll" "stdcall" }
{ "glu" "glu32.dll" "stdcall" }
{ "freetype" "freetype6.dll" "cdecl" }
+ { "ole32" "ole32.dll" "stdcall" }
} [ first3 add-library ] each
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
new file mode 100755
index 0000000000..6d62e17d6c
--- /dev/null
+++ b/extra/windows/ole32/ole32.factor
@@ -0,0 +1,43 @@
+USING: alien alien.syntax alien.c-types math kernel sequences
+windows windows.types ;
+IN: windows.ole32
+
+LIBRARY: ole32
+
+C-STRUCT: GUID
+ { "DWORD" "part1" }
+ { "DWORD" "part2" }
+ { "DWORD" "part3" }
+ { "DWORD" "part4" } ;
+
+TYPEDEF: void* REFGUID
+TYPEDEF: void* LPUNKNOWN
+TYPEDEF: ushort* LPOLESTR
+
+FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
+FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
+FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
+FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
+
+: S_OK 0 ; inline
+: S_FALSE 1 ; inline
+: E_FAIL HEX: 80004005 ; inline
+: E_INVALIDARG HEX: 80070057 ; inline
+
+: ole32-error ( n -- )
+ dup S_OK = [
+ drop
+ ] [ (win32-error-string) throw ] if ;
+
+: guid= ( a b -- ? )
+ IsEqualGUID c-bool> ;
+
+: GUID-STRING-LENGTH
+ "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
+
+: string>guid ( string -- guid )
+ string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
+: guid>string ( guid -- string )
+ GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
+ [ StringFromGUID2 drop ] { 2 } out-keep alien>u16-string ;
+
diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
old mode 100644
new mode 100755
index 501f49edfe..1d8d67dad7
--- a/extra/windows/shell32/shell32.factor
+++ b/extra/windows/shell32/shell32.factor
@@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax combinators
-kernel windows windows.user32 ;
+kernel windows windows.user32 windows.ole32 ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
@@ -68,10 +68,6 @@ IN: windows.shell32
: CSIDL_FLAG_MASK HEX: ff00 ; inline
-: S_OK 0 ; inline
-: S_FALSE 1 ; inline
-: E_FAIL HEX: 80004005 ; inline
-: E_INVALIDARG HEX: 80070057 ; inline
: ERROR_FILE_NOT_FOUND 2 ; inline
: SHGFP_TYPE_CURRENT 0 ; inline
@@ -89,15 +85,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
- dup S_OK = [
- drop
- ] [
- {
- ! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] }
- ! { E_INVALIDARG [ "invalid arg" throw ] }
- [ (win32-error-string) throw ]
- } case
- ] if ;
+ ole32-error ; inline
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
From 5f793727893e1eb658546ee8285a9353740fcf1c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 15 Feb 2008 22:51:52 -0800
Subject: [PATCH 003/197] Rename out-keep to multikeep and move it into
combinators.lib
---
core/alien/alien-docs.factor | 18 +-----------------
core/alien/alien.factor | 7 -------
extra/combinators/lib/lib.factor | 7 +++++++
extra/opengl/shaders/shaders.factor | 2 +-
extra/windows/ole32/ole32.factor | 4 ++--
5 files changed, 11 insertions(+), 27 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 68509db37f..19ee52b039 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -145,23 +145,7 @@ HELP: alien-callback
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
-HELP: out-keep
-{ $values { "quot" "A quotation" } { "out-indexes" "A sequence of indexes relative to the top of the stack" } }
-{ $description
- "Invokes " { $snippet "quot" } ", restoring the values to the stack indicated by " { $snippet "out-indexes" } ". This word is useful for calling C functions with out parameters. " { $snippet "quot" } " can invoke the function and manipulate its return value, after which the actually interesting values stored in the out parameters are brought back to the top of the stack." }
-{ $notes "The indexes in " { $snippet "out-indexes" } " are relative to the top of the stack, with " { $snippet "1" } " indicating the topmost value. This means that the indexes are reversed relative to the order in the C prototype; 1 indicates the rightmost parameter, and higher numbers count leftward." }
-{ $examples
- "A simple wrapper around memcpy (pretending that the return value is not equal to the out parameter):"
- { $code
- "LIBRARY: libc"
- "FUNCTION: void* memcpy ( void* out, void* in, size_t n ) ;"
- ": copy-byte-array ( a -- a' )"
- " dup length dup <byte-array> -rot"
- " [ memcpy drop ] { 3 } out-keep ;"
- }
-} ;
-
-{ alien-invoke alien-indirect alien-callback out-keep } related-words
+{ alien-invoke alien-indirect alien-callback } related-words
ARTICLE: "aliens" "Alien addresses"
"Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index b644846393..d5e9b5c3e9 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -90,10 +90,3 @@ TUPLE: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
2over \ alien-invoke-error construct-boa throw ;
-
-MACRO: out-keep ( word out-indexes -- ... )
- [
- dup >r [ \ npick \ >r 3array % ] each
- %
- r> [ drop \ r> , ] each
- ] [ ] make ;
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 9ccada1ec1..f73a99c1a2 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -167,3 +167,10 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
: and? ( obj quot1 quot2 -- ? )
>r keep r> rot [ call ] [ 2drop f ] if ; inline
+
+MACRO: multikeep ( word out-indexes -- ... )
+ [
+ dup >r [ \ npick \ >r 3array % ] each
+ %
+ r> [ drop \ r> , ] each
+ ] [ ] make ;
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index 7755df6513..6033933146 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -95,7 +95,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
dup gl-program-shaders-length
dup "GLuint" <c-array>
0 <int> swap
- [ glGetAttachedShaders ] { 3 1 } out-keep
+ [ glGetAttachedShaders ] { 3 1 } multikeep
c-uint-array> ;
: delete-gl-program-only ( program -- )
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
index 6d62e17d6c..ec0b02bc3f 100755
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -1,5 +1,5 @@
USING: alien alien.syntax alien.c-types math kernel sequences
-windows windows.types ;
+windows windows.types combinators.lib ;
IN: windows.ole32
LIBRARY: ole32
@@ -39,5 +39,5 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
- [ StringFromGUID2 drop ] { 2 } out-keep alien>u16-string ;
+ [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;
From 86e700cea06266e8c7cd1a0c2387750464552d39 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 12 Mar 2008 22:21:37 -0700
Subject: [PATCH 004/197] Fix macosx gl-function-address to use symbols from GL
library linked to VM
---
extra/opengl/gl/macosx/macosx.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/opengl/gl/macosx/macosx.factor b/extra/opengl/gl/macosx/macosx.factor
index 3d4cb6ae93..eb8dda5e33 100644
--- a/extra/opengl/gl/macosx/macosx.factor
+++ b/extra/opengl/gl/macosx/macosx.factor
@@ -2,5 +2,5 @@ USING: kernel alien ;
IN: opengl.gl.macosx
: gl-function-context ( -- context ) 0 ; inline
-: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline
+: gl-function-address ( name -- address ) f dlsym ; inline
: gl-function-calling-convention ( -- str ) "cdecl" ; inline
From c3d41967f7433002dff0b9b145ee824fcc21f888 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Thu, 13 Mar 2008 02:10:43 -0500
Subject: [PATCH 005/197] fix some formatting
---
extra/db/sqlite/lib/lib.factor | 15 ++++-----------
extra/db/sqlite/sqlite.factor | 35 ++++++++++------------------------
2 files changed, 14 insertions(+), 36 deletions(-)
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index dbada854fb..d630522eb8 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -102,17 +102,10 @@ IN: db.sqlite.lib
[ no-sql-type ]
} case ;
-: sqlite-finalize ( handle -- )
- sqlite3_finalize sqlite-check-result ;
-
-: sqlite-reset ( handle -- )
- sqlite3_reset sqlite-check-result ;
-
-: sqlite-#columns ( query -- int )
- sqlite3_column_count ;
-
-: sqlite-column ( handle index -- string )
- sqlite3_column_text ;
+: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-#columns ( query -- int ) sqlite3_column_count ;
+: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index b72d788605..9a9db74401 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -17,16 +17,11 @@ M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
-M: sqlite-db db-close ( handle -- )
- sqlite-close ;
-
+M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-
-: with-sqlite ( path quot -- )
- sqlite-db swap with-db ; inline
+: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
-
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
@@ -51,8 +46,7 @@ M: sqlite-result-set dispose ( result-set -- )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
-: reset-statement ( statement -- )
- statement-handle sqlite-reset ;
+: reset-statement ( statement -- ) statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
dup statement-bound? [ dup reset-statement ] when
@@ -98,14 +92,9 @@ M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
-M: sqlite-db begin-transaction ( -- )
- "BEGIN" sql-command ;
-
-M: sqlite-db commit-transaction ( -- )
- "COMMIT" sql-command ;
-
-M: sqlite-db rollback-transaction ( -- )
- "ROLLBACK" sql-command ;
+M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
+M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
+M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
@@ -123,9 +112,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
] sqlite-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
- [
- "drop table " 0% 0% ";" 0% drop
- ] sqlite-make ;
+ [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
@@ -195,10 +182,9 @@ M: sqlite-db modifier-table ( -- hashtable )
{ +not-null+ "not null" }
} ;
-M: sqlite-db compound-modifier ( str obj -- newstr )
- compound-type ;
+M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
-M: sqlite-db compound-type ( str seq -- newstr )
+M: sqlite-db compound-type ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
@@ -219,5 +205,4 @@ M: sqlite-db type-table ( -- assoc )
{ FACTOR-BLOB "blob" }
} ;
-M: sqlite-db create-type-table
- type-table ;
+M: sqlite-db create-type-table ( symbol -- str ) type-table ;
From 56afb67bfc22f72b712a4e196f4fed6be77ea4fa Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Fri, 14 Mar 2008 03:09:51 -0500
Subject: [PATCH 006/197] Unicode encoding changes
---
core/io/encodings/binary/binary.factor | 7 +-
core/io/encodings/encodings.factor | 126 ++++++++----------
core/io/encodings/utf8/utf8.factor | 94 ++++++--------
core/io/streams/string/string.factor | 4 +-
extra/io/encodings/ascii/ascii.factor | 20 +--
extra/io/encodings/latin1/latin1.factor | 10 +-
extra/io/encodings/utf16/utf16.factor | 163 ++++++++++--------------
7 files changed, 187 insertions(+), 237 deletions(-)
diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor
index b8bcc0f87a..5038628ed9 100644
--- a/core/io/encodings/binary/binary.factor
+++ b/core/io/encodings/binary/binary.factor
@@ -1,3 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.encodings.binary SYMBOL: binary
+USING: io.encodings kernel ;
+IN: io.encodings.binary
+
+TUPLE: binary ;
+M: binary <encoder> drop ;
+M: binary <decoder> drop ;
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 2f68334bde..b7c71d5527 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -2,62 +2,36 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces
growable strings io classes continuations combinators
-io.styles io.streams.plain io.encodings.binary splitting
-io.streams.duplex byte-arrays ;
+io.styles io.streams.plain splitting
+io.streams.duplex byte-arrays sequences.private ;
IN: io.encodings
! The encoding descriptor protocol
-GENERIC: decode-step ( buf char encoding -- )
-M: object decode-step drop swap push ;
+GENERIC: decode-char ( stream encoding -- char/f )
-GENERIC: init-decoder ( stream encoding -- encoding )
-M: tuple-class init-decoder construct-empty init-decoder ;
-M: object init-decoder nip ;
+GENERIC: encode-char ( char stream encoding -- )
-GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
-M: object stream-write-encoded drop stream-write ;
+GENERIC: <decoder> ( stream decoding -- newstream )
+
+GENERIC: <encoder> ( stream encoding -- newstream )
+
+: replacement-char HEX: fffd ;
! Decoding
+<PRIVATE
+
TUPLE: decode-error ;
: decode-error ( -- * ) \ decode-error construct-empty throw ;
-SYMBOL: begin
+TUPLE: decoder stream code cr ;
+M: tuple-class <decoder> construct-empty <decoder> ;
+M: tuple <decoder> f decoder construct-boa ;
-: push-decoded ( buf ch -- buf ch state )
- over push 0 begin ;
-
-: push-replacement ( buf -- buf ch state )
- ! This is the replacement character
- HEX: fffd push-decoded ;
-
-: space ( resizable -- room-left )
- dup underlying swap [ length ] 2apply - ;
-
-: full? ( resizable -- ? ) space zero? ;
-
-: end-read-loop ( buf ch state stream quot -- string/f )
- 2drop 2drop >string f like ;
-
-: decode-read-loop ( buf stream encoding -- string/f )
- pick full? [ 2drop >string ] [
- over stream-read1 [
- -rot tuck >r >r >r dupd r> decode-step r> r>
- decode-read-loop
- ] [ 2drop >string f like ] if*
- ] if ;
-
-: decode-read ( length stream encoding -- string )
- rot <sbuf> -rot decode-read-loop ;
-
-TUPLE: decoder code cr ;
-: <decoder> ( stream encoding -- newstream )
- dup binary eq? [ drop ] [
- dupd init-decoder { set-delegate set-decoder-code }
- decoder construct
- ] if ;
+: >decoder< ( decoder -- stream encoding )
+ { decoder-stream decoder-code } get-slots ;
: cr+ t swap set-decoder-cr ; inline
@@ -82,72 +56,78 @@ TUPLE: decoder code cr ;
over decoder-cr [
over cr-
"\n" ?head [
- swap stream-read1 [ add ] when*
- ] [ nip ] if
- ] [ nip ] if ;
+ over stream-read1 [ add ] when*
+ ] when
+ ] when nip ;
+
+: read-loop ( n stream -- string )
+ over 0 <string> [
+ [
+ >r stream-read1 dup
+ [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
+ ] 2curry find-integer
+ ] keep swap [ head ] when* ;
M: decoder stream-read
- tuck { delegate decoder-code } get-slots decode-read fix-read ;
+ tuck read-loop fix-read ;
-M: decoder stream-read-partial stream-read ;
-
-: decoder-read-until ( stream delim -- ch )
- ! Copied from { c-reader stream-read-until }!!!
- over stream-read1 dup [
- dup pick memq? [ 2nip ] [ , decoder-read-until ] if
- ] [
- 2nip
- ] if ;
+: (read-until) ( buf quot -- string/f sep/f )
+ ! quot: -- char keep-going?
+ dup call
+ [ >r drop "" like r> ]
+ [ pick push (read-until) ] if ; inline
M: decoder stream-read-until
- ! Copied from { c-reader stream-read-until }!!!
- [ swap decoder-read-until ] "" make
- swap over empty? over not and [ 2drop f f ] when ;
+ SBUF" " clone -rot >decoder<
+ [ decode-char dup rot memq? ] 3curry (read-until) ;
: fix-read1 ( stream char -- char )
over decoder-cr [
over cr-
dup CHAR: \n = [
- drop stream-read1
- ] [ nip ] if
- ] [ nip ] if ;
+ drop dup stream-read1
+ ] when
+ ] when nip ;
M: decoder stream-read1
- 1 swap stream-read f like [ first ] [ f ] if* ;
+ dup >decoder< decode-char fix-read1 ;
M: decoder stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;
+M: decoder dispose decoder-stream dispose ;
+
! Encoding
TUPLE: encode-error ;
: encode-error ( -- * ) \ encode-error construct-empty throw ;
-TUPLE: encoder code ;
-: <encoder> ( stream encoding -- newstream )
- dup binary eq? [ drop ] [
- construct-empty { set-delegate set-encoder-code }
- encoder construct
- ] if ;
+TUPLE: encoder stream code ;
+M: tuple-class <encoder> construct-empty <encoder> ;
+M: tuple <encoder> encoder construct-boa ;
+
+: >encoder< ( encoder -- stream encoding )
+ { encoder-stream encoder-code } get-slots ;
M: encoder stream-write1
- >r 1string r> stream-write ;
+ >encoder< encode-char ;
M: encoder stream-write
- { delegate encoder-code } get-slots stream-write-encoded ;
+ >encoder< [ encode-char ] 2curry each ;
-M: encoder dispose delegate dispose ;
+M: encoder dispose encoder-stream dispose ;
INSTANCE: encoder plain-writer
! Rebinding duplex streams which have not read anything yet
: reencode ( stream encoding -- newstream )
- over encoder? [ >r delegate r> ] when <encoder> ;
+ over encoder? [ >r encoder-stream r> ] when <encoder> ;
: redecode ( stream encoding -- newstream )
- over decoder? [ >r delegate r> ] when <decoder> ;
+ over decoder? [ >r decoder-stream r> ] when <decoder> ;
+PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;
diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor
index 5887a8375e..02b10c45a5 100644
--- a/core/io/encodings/utf8/utf8.factor
+++ b/core/io/encodings/utf8/utf8.factor
@@ -6,82 +6,68 @@ IN: io.encodings.utf8
! Decoding UTF-8
-TUPLE: utf8 ch state ;
+TUPLE: utf8 ;
-SYMBOL: double
-SYMBOL: triple
-SYMBOL: triple2
-SYMBOL: quad
-SYMBOL: quad2
-SYMBOL: quad3
+<PRIVATE
: starts-2? ( char -- ? )
- -6 shift BIN: 10 number= ;
+ dup [ -6 shift BIN: 10 number= ] when ;
-: append-nums ( buf bottom top state-out -- buf num state )
- >r over starts-2?
- [ 6 shift swap BIN: 111111 bitand bitor r> ]
- [ r> 3drop push-replacement ] if ;
+: append-nums ( stream byte -- stream char )
+ over stream-read1 dup starts-2?
+ [ 6 shift swap BIN: 111111 bitand bitor ]
+ [ 2drop replacement-char ] if ;
-: begin-utf8 ( buf byte -- buf ch state )
+: double ( stream byte -- stream char )
+ BIN: 11111 bitand append-nums ;
+
+: triple ( stream byte -- stream char )
+ BIN: 1111 bitand append-nums append-nums ;
+
+: quad ( stream byte -- stream char )
+ BIN: 111 bitand append-nums append-nums append-nums ;
+
+: begin-utf8 ( stream byte -- stream char )
{
- { [ dup -7 shift zero? ] [ push-decoded ] }
- { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
- { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
- { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
- { [ t ] [ drop push-replacement ] }
+ { [ dup -7 shift zero? ] [ ] }
+ { [ dup -5 shift BIN: 110 number= ] [ double ] }
+ { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
+ { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
+ { [ t ] [ drop replacement-char ] }
} cond ;
-: end-multibyte ( buf byte ch -- buf ch state )
- f append-nums [ push-decoded ] unless* ;
+: decode-utf8 ( stream -- char/f )
+ dup stream-read1 dup [ begin-utf8 ] when nip ;
-: decode-utf8-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop begin-utf8 ] }
- { double [ end-multibyte ] }
- { triple [ triple2 append-nums ] }
- { triple2 [ end-multibyte ] }
- { quad [ quad2 append-nums ] }
- { quad2 [ quad3 append-nums ] }
- { quad3 [ end-multibyte ] }
- } case ;
-
-: unpack-state ( encoding -- ch state )
- { utf8-ch utf8-state } get-slots ;
-
-: pack-state ( ch state encoding -- )
- { set-utf8-ch set-utf8-state } set-slots ;
-
-M: utf8 decode-step ( buf char encoding -- )
- [ unpack-state decode-utf8-step ] keep pack-state drop ;
-
-M: utf8 init-decoder nip begin over set-utf8-state ;
+M: utf8 decode-char
+ drop decode-utf8 ;
! Encoding UTF-8
-: encoded ( char -- )
- BIN: 111111 bitand BIN: 10000000 bitor write1 ;
+: encoded ( stream char -- )
+ BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
-: char>utf8 ( char -- )
+: char>utf8 ( stream char -- )
{
- { [ dup -7 shift zero? ] [ write1 ] }
+ { [ dup -7 shift zero? ] [ swap stream-write1 ] }
{ [ dup -11 shift zero? ] [
- dup -6 shift BIN: 11000000 bitor write1
+ 2dup -6 shift BIN: 11000000 bitor swap stream-write1
encoded
] }
{ [ dup -16 shift zero? ] [
- dup -12 shift BIN: 11100000 bitor write1
- dup -6 shift encoded
+ 2dup -12 shift BIN: 11100000 bitor swap stream-write1
+ 2dup -6 shift encoded
encoded
] }
{ [ t ] [
- dup -18 shift BIN: 11110000 bitor write1
- dup -12 shift encoded
- dup -6 shift encoded
+ 2dup -18 shift BIN: 11110000 bitor swap stream-write1
+ 2dup -12 shift encoded
+ 2dup -6 shift encoded
encoded
] }
} cond ;
-M: utf8 stream-write-encoded
- ! For efficiency, this should be modified to avoid variable reads
- drop [ [ char>utf8 ] each ] with-stream* ;
+M: utf8 encode-char
+ drop swap char>utf8 ;
+
+PRIVATE>
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index 7833e0aa47..33404292a9 100755
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
-io.encodings ;
+io.encodings io.encodings.private ;
+IN: io.streams.string
M: growable dispose drop ;
diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor
index bd71b733f1..16d87ef39c 100644
--- a/extra/io/encodings/ascii/ascii.factor
+++ b/extra/io/encodings/ascii/ascii.factor
@@ -1,18 +1,20 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
+USING: io io.encodings kernel math ;
IN: io.encodings.ascii
-: encode-check< ( string stream max -- )
- [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
+<PRIVATE
+: encode-if< ( char stream encoding max -- )
+ nip pick > [ encode-error ] [ stream-write1 ] if ;
-: push-if< ( sbuf character max -- )
- over <= [ drop HEX: fffd ] when swap push ;
+: decode-if< ( stream encoding max -- character )
+ nip swap stream-read1 tuck > [ drop replacement-character ] unless ;
+PRIVATE>
TUPLE: ascii ;
-M: ascii stream-write-encoded ( string stream encoding -- )
- drop 128 encode-check< ;
+M: ascii encode-char
+ 128 encode-if< ;
-M: ascii decode-step
- drop 128 push-if< ;
+M: ascii decode-char
+ 128 decode-if< ;
diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor
index 71e98a1747..2b82318885 100755
--- a/extra/io/encodings/latin1/latin1.factor
+++ b/extra/io/encodings/latin1/latin1.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings strings kernel io.encodings.ascii sequences math ;
+USING: io io.encodings kernel io.encodings.ascii.private ;
IN: io.encodings.latin1
TUPLE: latin1 ;
-M: latin1 stream-write-encoded
- drop 256 encode-check< ;
+M: latin1 encode-char
+ 256 encode-if< ;
-M: latin1 decode-step
- drop swap push ;
+M: latin1 decode-char
+ drop stream-read1 ;
diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor
index a501fad0bd..7e82935db7 100755
--- a/extra/io/encodings/utf16/utf16.factor
+++ b/extra/io/encodings/utf16/utf16.factor
@@ -4,92 +4,71 @@ USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting io byte-arrays ;
IN: io.encodings.utf16
-! UTF-16BE decoding
-
-TUPLE: utf16be ch state ;
-
-SYMBOL: double
-SYMBOL: quad1
-SYMBOL: quad2
-SYMBOL: quad3
-SYMBOL: ignore
-
-: do-ignore ( -- ch state ) 0 ignore ;
-
-: append-nums ( byte ch -- ch )
- 8 shift bitor ;
-
-: end-multibyte ( buf byte ch -- buf ch state )
- append-nums push-decoded ;
-
-: begin-utf16be ( buf byte -- buf ch state )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad1 ]
- [ drop do-ignore ] if
- ] [ double ] if ;
-
-: handle-quad2be ( byte ch -- ch state )
- swap dup -2 shift BIN: 110111 number= [
- >r 2 shift r> BIN: 11 bitand bitor quad3
- ] [ 2drop do-ignore ] if ;
-
-: decode-utf16be-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop begin-utf16be ] }
- { double [ end-multibyte ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ handle-quad2be ] }
- { quad3 [ append-nums HEX: 10000 + push-decoded ] }
- { ignore [ 2drop push-replacement ] }
- } case ;
-
-: unpack-state-be ( encoding -- ch state )
- { utf16be-ch utf16be-state } get-slots ;
-
-: pack-state-be ( ch state encoding -- )
- { set-utf16be-ch set-utf16be-state } set-slots ;
-
-M: utf16be decode-step
- [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ;
-
-M: utf16be init-decoder nip begin over set-utf16be-state ;
-
-! UTF-16LE decoding
+TUPLE: utf16be ;
TUPLE: utf16le ch state ;
-: handle-double ( buf byte ch -- buf ch state )
- swap dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad2 ]
- [ 2drop push-replacement ] if
- ] [ end-multibyte ] if ;
+TUPLE: utf16 started? ;
-: handle-quad3le ( buf byte ch -- buf ch state )
- swap dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 + push-decoded
- ] [ 2drop push-replacement ] if ;
+<PRIVATE
+
+! UTF-16BE decoding
+
+: append-nums ( byte ch -- ch )
+ over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
+
+: double-be ( stream byte -- stream char )
+ over stream-read1 swap append-nums ;
+
+: quad-be ( stream byte -- stream char )
+ double-be over stream-read1 dup [
+ dup -2 shift BIN: 110111 number= [
+ >r 2 shift r> BIN: 11 bitand bitor
+ over stream-read1 swap append-nums HEX: 10000 +
+ ] [ 2drop replacement-char ] if
+ ] when ;
+
+: ignore ( stream -- stream char )
+ dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
+ dup -3 shift BIN: 11011 number= [
+ dup BIN: 00000100 bitand zero?
+ [ BIN: 11 bitand quad-be ]
+ [ drop ignore ] if
+ ] [ double-be ] if ;
+
+M: decode-char
+ drop dup stream-read1 dup [ begin-utf16be ] when nip ;
+
+! UTF-16LE decoding
+
+: quad-le ( stream ch -- stream char )
+ over stream-read1 swap 10 shift bitor
+ over stream-read1 dup -2 shift BIN: 110111 = [
+ BIN: 11 bitand append-nums HEX: 10000 +
+ ] [ 2drop replacement-char ] if ;
+
+: double-le ( stream byte1 byte2 -- stream char )
+ dup -3 shift BIN: 11011 = [
+ dup BIN: 100 bitand 0 number=
+ [ BIN: 11 bitand 8 shift bitor quad-le ]
+ [ 2drop replacement-char ] if
+ ] [ swap append-nums ] if ;
: decode-utf16le-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop double ] }
{ double [ handle-double ] }
- { quad1 [ append-nums quad2 ] }
{ quad2 [ 10 shift bitor quad3 ] }
{ quad3 [ handle-quad3le ] }
} case ;
-: unpack-state-le ( encoding -- ch state )
- { utf16le-ch utf16le-state } get-slots ;
+: begin-utf16le ( stream byte -- stream char )
+ over stream-read1 [ double-le ] [ drop replacement-char ] if*
-: pack-state-le ( ch state encoding -- )
- { set-utf16le-ch set-utf16le-state } set-slots ;
-
-M: utf16le decode-step
- [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ;
-
-M: utf16le init-decoder nip begin over set-utf16le-state ;
+M: decode-char
+ drop dup stream-read1 dup [ begin-utf16le ] when nip ;
! UTF-16LE/BE encoding
@@ -103,25 +82,25 @@ M: utf16le init-decoder nip begin over set-utf16le-state ;
dup -8 shift BIN: 11011100 bitor
swap BIN: 11111111 bitand ;
-: char>utf16be ( char -- )
+: stream-write2 ( stream char1 char2 -- )
+ rot [ stream-write1 ] 2apply ;
+
+: char>utf16be ( stream char -- )
dup HEX: FFFF > [
HEX: 10000 -
- dup encode-first swap write1 write1
- encode-second swap write1 write1
- ] [ h>b/b write1 write1 ] if ;
+ dup encode-first stream-write2
+ encode-second stream-write2
+ ] [ h>b/b swap stream-write2 ] if ;
-: stream-write-utf16be ( string stream -- )
- [ [ char>utf16be ] each ] with-stream* ;
-
-M: utf16be stream-write-encoded ( string stream encoding -- )
- drop stream-write-utf16be ;
+M: utf16be encode-char ( char stream encoding -- )
+ drop char>utf16be ;
: char>utf16le ( char -- )
dup HEX: FFFF > [
HEX: 10000 -
- dup encode-first write1 write1
- encode-second write1 write1
- ] [ h>b/b swap write1 write1 ] if ;
+ dup encode-first swap stream-write2
+ encode-second swap stream-write2
+ ] [ h>b/b stream-write2 ] if ;
: stream-write-utf16le ( string stream -- )
[ [ char>utf16le ] each ] with-stream* ;
@@ -139,17 +118,15 @@ M: utf16le stream-write-encoded ( string stream encoding -- )
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
-TUPLE: utf16 started? ;
-
-M: utf16 stream-write-encoded
- dup utf16-started? [ drop ]
- [ t swap set-utf16-started? bom-le over stream-write ] if
- stream-write-utf16le ;
-
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [
bom-be sequence= [ utf16be ] [ decode-error ] if
] if ;
-M: utf16 init-decoder ( stream encoding -- newencoding )
- 2 rot stream-read bom>le/be construct-empty init-decoder ;
+M: utf16 <decoder> ( stream utf16 -- decoder )
+ 2 rot stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+ drop bom-le over stream-write utf16le <encoder> ;
+
+PRIVATE>
From 8a2e52a10b67c7fb61241502fdceab7bff93f42b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 14 Mar 2008 10:54:20 -0600
Subject: [PATCH 007/197] builder: fix bug
---
extra/builder/builder.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 52150b07a8..7d95ce2409 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -134,7 +134,9 @@ SYMBOL: build-status
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
- "test-all-vocabs" eval-file test-failures.
+ "test-failures" cat
+
+! "test-failures" eval-file test-failures.
"help-lint results:" print "help-lint" cat
From 080628af9ff52d6ca01fff09900310d4c26d37c2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 14 Mar 2008 10:54:46 -0600
Subject: [PATCH 008/197] fix ldap and openssl on unix
---
extra/ldap/libldap/libldap.factor | 4 ++--
extra/openssl/libcrypto/libcrypto.factor | 4 ++--
extra/openssl/libssl/libssl.factor | 4 ++--
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor
index ae613bd461..6db6884071 100755
--- a/extra/ldap/libldap/libldap.factor
+++ b/extra/ldap/libldap/libldap.factor
@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: ldap.libldap
<< "libldap" {
- { [ win32? ] [ "libldap.dll" "stdcall" ] }
+ { [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
+ { [ unix? ] [ "libldap.so" "cdecl" ] }
} cond add-library >>
: LDAP_VERSION1 1 ; inline
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index 8378a11956..7b3ad2cf9f 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libcrypto
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "stdcall" ] }
+ { [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libcrypto.so" "cdecl" ] }
+ { [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
C-STRUCT: bio-method
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 8d1b3b5247..d8709cbf53 100644
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
- { [ win32? ] [ "ssleay32.dll" "stdcall" ] }
+ { [ win32? ] [ "ssleay32.dll" "stdcall" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
+ { [ unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
From d6fb777e508aad4d7785515e99c7dd3fd45c69ef Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jamesdesktop.(none)>
Date: Fri, 14 Mar 2008 12:56:36 -0500
Subject: [PATCH 009/197] write a replace word and 2seq>assoc
---
extra/assocs/lib/lib.factor | 5 ++++-
extra/sequences/lib/lib.factor | 6 +++++-
2 files changed, 9 insertions(+), 2 deletions(-)
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 88095759e6..d2eb42a117 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -1,4 +1,4 @@
-USING: assocs kernel vectors sequences namespaces ;
+USING: arrays assocs kernel vectors sequences namespaces ;
IN: assocs.lib
: >set ( seq -- hash )
@@ -35,3 +35,6 @@ IN: assocs.lib
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;
+
+: 2seq>assoc ( keys values exemplar -- assoc )
+ >r 2array flip r> assoc-like ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 050de0ae1c..fe0ee52ff4 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -3,7 +3,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
-arrays math.parser math.private sorting strings ascii macros ;
+arrays math.parser math.private sorting strings ascii macros
+assocs.lib ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@@ -220,3 +221,6 @@ PRIVATE>
: nths ( indices seq -- seq' )
[ swap nth ] with map ;
+
+: replace ( str oldseq newseq -- str' )
+ H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ;
From 21d52749a27149aa44fd3f7c87a62d91ab0bdaa2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 14 Mar 2008 12:58:10 -0600
Subject: [PATCH 010/197] io.files: 'directory?' uses file-info
---
core/io/files/files.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 3ab489739b..18cdbd3791 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -94,7 +94,9 @@ SYMBOL: +unknown+
: exists? ( path -- ? ) file-modified >boolean ;
-: directory? ( path -- ? ) stat 3drop ;
+! : directory? ( path -- ? ) stat 3drop ;
+
+: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
! Current working directory
HOOK: cd io-backend ( path -- )
From 02758aeadbac0ebe4c93d2284cc3cab1bc80d93b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 14 Mar 2008 12:59:17 -0600
Subject: [PATCH 011/197] combinators.cleave: <arr> and <arr*>
---
extra/combinators/cleave/cleave.factor | 26 ++++++++++++++++++++++++++
1 file changed, 26 insertions(+)
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index fd66536c12..049c8bf2a9 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -70,3 +70,29 @@ MACRO: spread ( seq -- )
swap
[ [ r> ] swap append ] map concat
append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Cleave into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: words quotations fry arrays.lib ;
+
+: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+
+: >quots ( seq -- seq ) [ >quot ] map ;
+
+MACRO: <arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ , cleave , narray ] ;
+
+MACRO: <2arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ , 2cleave , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Spread into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr*> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ , spread , narray ] ;
From 2029be73440b86b9a1b8e037cc79e4224ddc5eb4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 14 Mar 2008 16:44:40 -0500
Subject: [PATCH 012/197] better replace word
---
extra/sequences/lib/lib.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index fe0ee52ff4..13e8eb949f 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -223,4 +223,4 @@ PRIVATE>
[ swap nth ] with map ;
: replace ( str oldseq newseq -- str' )
- H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ;
+ H{ } 2seq>assoc substitute ;
From f1cadef89d747975d44a726bac3b6490718d8800 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 14 Mar 2008 17:39:57 -0500
Subject: [PATCH 013/197] More deployment fixes
---
extra/hello-world/deploy.factor | 14 +++++++-------
extra/sudoku/deploy.factor | 17 +++++++++--------
extra/tools/deploy/backend/backend.factor | 12 +++++++-----
extra/tools/deploy/deploy-tests.factor | 23 +++++++++++++----------
extra/tools/deploy/shaker/shaker.factor | 7 ++++---
5 files changed, 40 insertions(+), 33 deletions(-)
diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor
index 45d19cb891..2341aabc9d 100755
--- a/extra/hello-world/deploy.factor
+++ b/extra/hello-world/deploy.factor
@@ -1,14 +1,14 @@
USING: tools.deploy.config ;
H{
- { deploy-io 2 }
- { deploy-math? f }
- { deploy-threads? f }
- { deploy-compiler? f }
- { deploy-word-props? f }
- { deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
- { deploy-reflection 2 }
+ { deploy-threads? f }
{ deploy-c-types? f }
+ { deploy-compiler? f }
{ deploy-ui? f }
+ { deploy-math? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-io 2 }
+ { deploy-word-props? f }
{ "stop-after-last-window?" t }
}
diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor
index de60bed20b..11a06f46bc 100755
--- a/extra/sudoku/deploy.factor
+++ b/extra/sudoku/deploy.factor
@@ -1,13 +1,14 @@
USING: tools.deploy.config ;
H{
- { deploy-reflection 2 }
- { deploy-word-props? f }
- { deploy-compiler? t }
- { deploy-math? f }
- { deploy-c-types? f }
- { deploy-io 2 }
- { deploy-ui? f }
{ deploy-name "Sudoku" }
- { "stop-after-last-window?" t }
+ { deploy-threads? f }
+ { deploy-c-types? f }
+ { deploy-compiler? t }
+ { deploy-ui? f }
+ { deploy-math? f }
+ { deploy-reflection 1 }
{ deploy-word-defs? f }
+ { deploy-io 2 }
+ { deploy-word-props? f }
+ { "stop-after-last-window?" t }
}
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 15dc32115e..60dc11257f 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -65,8 +65,12 @@ IN: tools.deploy.backend
: run-factor ( vm flags -- )
swap add* dup . run-with-output ; inline
-: make-staging-image ( vm config -- )
- staging-command-line run-factor ;
+: make-staging-image ( config -- )
+ vm swap staging-command-line run-factor ;
+
+: ?make-staging-image ( config -- )
+ dup [ staging-image-name ] bind exists?
+ [ drop ] [ make-staging-image ] if ;
: deploy-command-line ( image vocab config -- flags )
[
@@ -85,9 +89,7 @@ IN: tools.deploy.backend
: make-deploy-image ( vm image vocab config -- )
make-boot-image
- dup staging-image-name exists? [
- >r pick r> tuck make-staging-image
- ] unless
+ dup ?make-staging-image
deploy-command-line run-factor ;
SYMBOL: deploy-implementation
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index a6e126ea9e..6d3385d0a4 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -1,44 +1,47 @@
IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config
-tools.deploy.backend math sequences io.launcher ;
+tools.deploy.backend math sequences io.launcher arrays ;
-: shake-and-bake
+: shake-and-bake ( vocab -- )
"." resource-path [
- vm
+ >r vm
"test.image" temp-file
- rot dup deploy-config make-deploy-image
+ r> dup deploy-config make-deploy-image
] with-directory ;
+: small-enough? ( n -- ? )
+ >r "test.image" temp-file file-info file-info-size r> <= ;
+
[ ] [ "hello-world" shake-and-bake ] unit-test
[ t ] [
- "hello.image" temp-file file-info file-info-size 500000 <=
+ 500000 small-enough?
] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [
- "hello.image" temp-file file-info file-info-size 1500000 <=
+ 1500000 small-enough?
] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [
- "hello.image" temp-file file-info file-info-size 2000000 <=
+ 2000000 small-enough?
] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [
- "hello.image" temp-file file-info file-info-size 3000000 <=
+ 3000000 small-enough?
] unit-test
[ ] [
"tools.deploy.test.1" shake-and-bake
- vm "-i=" "test.image" temp-file append try-process
+ vm "-i=" "test.image" temp-file append 2array try-process
] unit-test
[ ] [
"tools.deploy.test.2" shake-and-bake
- vm "-i=" "test.image" temp-file append try-process
+ vm "-i=" "test.image" temp-file append 2array try-process
] unit-test
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index bddf3d76c9..edf78de479 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -13,7 +13,6 @@ QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: inspector
QUALIFIED: io.backend
-QUALIFIED: io.nonblocking
QUALIFIED: io.thread
QUALIFIED: layouts
QUALIFIED: libc.private
@@ -133,8 +132,10 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when
- { io.backend:io-backend io.nonblocking:default-buffer-size }
- { "alarms" "io" "tools" } strip-vocab-globals %
+ [
+ io.backend:io-backend
+ "default-buffer-size" "io.nonblocking" lookup ,
+ ] { "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
From 16244ab15aeed1523d72af0891055ef74ea50598 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 14 Mar 2008 17:40:08 -0500
Subject: [PATCH 014/197] Run dtors in reverse order
---
extra/destructors/destructors.factor | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor
index b2561c7439..1b98d2ee0d 100755
--- a/extra/destructors/destructors.factor
+++ b/extra/destructors/destructors.factor
@@ -26,11 +26,14 @@ M: destructor dispose
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
+: dispose-each ( seq -- )
+ <reversed> [ dispose ] each ;
+
: do-always-destructors ( -- )
- always-destructors get [ dispose ] each ;
+ always-destructors get dispose-each ;
: do-error-destructors ( -- )
- error-destructors get [ dispose ] each ;
+ error-destructors get dispose-each ;
: with-destructors ( quot -- )
[
From d6d71aeb131160e3a643393aabd470876aae0af3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 14 Mar 2008 17:40:47 -0500
Subject: [PATCH 015/197] Fixing httpd bugs
---
extra/http/server/actions/actions.factor | 5 -
.../http/server/auth/login/edit-profile.fhtml | 77 ++++++++++++
extra/http/server/auth/login/login.factor | 110 ++++++++++++++----
extra/http/server/auth/login/recover-3.fhtml | 2 +-
extra/http/server/auth/login/register.fhtml | 2 +-
.../server/auth/providers/providers.factor | 4 +-
.../server/components/components-tests.factor | 13 +++
.../http/server/components/components.factor | 16 +--
.../server/validators/validators-tests.factor | 6 +-
.../http/server/validators/validators.factor | 33 +++---
10 files changed, 212 insertions(+), 56 deletions(-)
create mode 100755 extra/http/server/auth/login/edit-profile.fhtml
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 72c2d2df8e..7bee96edce 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -17,11 +17,6 @@ TUPLE: action init display submit get-params post-params ;
[ <400> ] >>display
[ <400> ] >>submit ;
-: with-validator ( string quot -- result error? )
- '[ , @ f ] [
- dup validation-error? [ t ] [ rethrow ] if
- ] recover ; inline
-
: validate-param ( name validator assoc -- error? )
swap pick
>r >r at r> with-validator swap r> set ;
diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml
new file mode 100755
index 0000000000..7d94ca1791
--- /dev/null
+++ b/extra/http/server/auth/login/edit-profile.fhtml
@@ -0,0 +1,77 @@
+<% USING: http.server.components http.server.auth.login
+http.server namespaces kernel combinators ; %>
+<html>
+<body>
+<h1>Edit profile</h1>
+
+<form method="POST" action="edit-profile">
+<% hidden-form-field %>
+
+<table>
+
+<tr>
+<td>User name:</td>
+<td><% "username" component render-view %></td>
+</tr>
+
+<tr>
+<td>Real name:</td>
+<td><% "realname" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>Specifying a real name is optional.</td>
+</tr>
+
+<tr>
+<td>Current password:</td>
+<td><% "password" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>If you don't want to change your current password, leave this field blank.</td>
+</tr>
+
+<tr>
+<td>New password:</td>
+<td><% "new-password" component render-edit %></td>
+</tr>
+
+<tr>
+<td>Verify:</td>
+<td><% "verify-password" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>If you are changing your password, enter it twice to ensure it is correct.</td>
+</tr>
+
+<tr>
+<td>E-mail:</td>
+<td><% "email" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+</tr>
+
+</table>
+
+<p><input type="submit" value="Update" />
+
+<% {
+ { [ login-failed? get ] [ "invalid password" render-error ] }
+ { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
+ { [ t ] [ ] }
+} cond %>
+
+</p>
+
+</form>
+
+</body>
+</html>
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 9b2648158d..8842e1639e 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -13,6 +13,8 @@ QUALIFIED: smtp
TUPLE: login users ;
+: users login get users>> ;
+
SYMBOL: post-login-url
SYMBOL: login-failed?
@@ -49,7 +51,7 @@ SYMBOL: login-failed?
form validate-form
"password" value "username" value
- login get users>> check-login [
+ users check-login [
successful-login
] [
login-failed? on
@@ -67,7 +69,7 @@ SYMBOL: login-failed?
t >>required
add-field
"realname" <string> add-field
- "password" <password>
+ "new-password" <password>
t >>required
add-field
"verify-password" <password>
@@ -80,7 +82,7 @@ SYMBOL: password-mismatch?
SYMBOL: user-exists?
: same-password-twice ( -- )
- "password" value "verify-password" value = [
+ "new-password" value "verify-password" value = [
password-mismatch? on
validation-failed
] unless ;
@@ -102,14 +104,13 @@ SYMBOL: user-exists?
same-password-twice
- <user> values get [
- "username" get >>username
- "realname" get >>realname
- "password" get >>password
- "email" get >>email
- ] bind
+ <user>
+ "username" value >>username
+ "realname" value >>realname
+ "new-password" value >>password
+ "email" value >>email
- login get users>> new-user [
+ users new-user [
user-exists? on
validation-failed
] unless*
@@ -118,6 +119,64 @@ SYMBOL: user-exists?
] >>submit
] ;
+! ! ! Editing user profile
+
+: <edit-profile-form> ( -- form )
+ "edit-profile" <form>
+ "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
+ "username" <username> add-field
+ "realname" <string> add-field
+ "password" <password> add-field
+ "new-password" <password> add-field
+ "verify-password" <password> add-field
+ "email" <email> add-field ;
+
+SYMBOL: previous-page
+
+:: <edit-profile-action> ( -- action )
+ [let | form [ <edit-profile-form> ] |
+ <action>
+ [
+ blank-values
+ logged-in-user sget
+ dup username>> "username" set-value
+ dup realname>> "realname" set-value
+ dup email>> "email" set-value
+ ] >>init
+
+ [
+ "text/html" <content>
+ [ form edit-form ] >>body
+ ] >>display
+
+ [
+ blank-values
+ uid "username" set-value
+
+ form validate-form
+
+ "password" value empty? [
+ logged-in-user sget
+ ] [
+ same-password-twice
+
+ "password" value uid users check-login
+ [ login-failed? on validation-failed ] unless
+
+ "new-password" value uid users set-password
+ [ "User deleted" throw ] unless*
+ ] if
+
+ "realname" value >>realname
+ "email" value >>email
+
+ dup users update-user
+ logged-in-user sset
+
+ previous-page sget dup [ f <permanent-redirect> ] when
+ ] >>submit
+ ] ;
+
! ! ! Password recovery
SYMBOL: lost-password-from
@@ -186,7 +245,7 @@ SYMBOL: lost-password-from
form validate-form
"email" value "username" value
- login get users>> issue-ticket [
+ users issue-ticket [
send-password-email
] when*
@@ -200,7 +259,7 @@ SYMBOL: lost-password-from
"username" <username> <hidden>
t >>required
add-field
- "password" <password>
+ "new-password" <password>
t >>required
add-field
"verify-password" <password>
@@ -239,9 +298,9 @@ SYMBOL: lost-password-from
"ticket" value
"username" value
- login get users>> claim-ticket [
- "password" value >>password
- login get users>> update-user
+ users claim-ticket [
+ "new-password" value >>password
+ users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template
@@ -265,13 +324,18 @@ TUPLE: protected responder ;
C: <protected> protected
+: show-login-page ( -- response )
+ request get request-url post-login-url sset
+ "login" f <permanent-redirect> ;
+
M: protected call-responder ( path responder -- response )
- logged-in-user sget [ responder>> call-responder ] [
+ logged-in-user sget [
+ request get request-url previous-page sset
+ responder>> call-responder
+ ] [
2drop
- request get method>> { "GET" "HEAD" } member? [
- request get request-url post-login-url sset
- "login" f <permanent-redirect>
- ] [ <400> ] if
+ request get method>> { "GET" "HEAD" } member?
+ [ show-login-page ] [ <400> ] if
] if ;
M: login call-responder ( path responder -- response )
@@ -287,6 +351,9 @@ M: login call-responder ( path responder -- response )
! ! ! Configuration
+: allow-edit-profile ( login -- login )
+ <edit-profile-action> <protected> "edit-profile" add-responder ;
+
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
@@ -294,6 +361,9 @@ M: login call-responder ( path responder -- response )
<recover-action-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ;
+: allow-edit-profile? ( -- ? )
+ login get responders>> "edit-profile" swap key? ;
+
: allow-registration? ( -- ? )
login get responders>> "register" swap key? ;
diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml
index edd32fffe8..ca4823baab 100755
--- a/extra/http/server/auth/login/recover-3.fhtml
+++ b/extra/http/server/auth/login/recover-3.fhtml
@@ -17,7 +17,7 @@ namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
-<td><% "password" component render-edit %></td>
+<td><% "new-password" component render-edit %></td>
</tr>
<tr>
diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml
index 99d1547d03..9106497def 100755
--- a/extra/http/server/auth/login/register.fhtml
+++ b/extra/http/server/auth/login/register.fhtml
@@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
-<td><% "password" component render-edit %></td>
+<td><% "new-password" component render-edit %></td>
</tr>
<tr>
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index 0aa27f870d..74620a4f5d 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -17,12 +17,12 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
-:: set-password ( password username provider -- ? )
+:: set-password ( password username provider -- user/f )
[let | user [ username provider get-user ] |
user [
user
password >>password
- provider update-user t
+ provider dup update-user
] [ f ] if
] ;
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
index 2a507e6416..83ae7b0118 100755
--- a/extra/http/server/components/components-tests.factor
+++ b/extra/http/server/components/components-tests.factor
@@ -86,3 +86,16 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "number" value validation-error? ] unit-test
] with-scope
+
+[
+ [ ] [
+ "n" <number>
+ 0 >>min-value
+ 10 >>max-value
+ "n" set
+ ] unit-test
+
+ [ "123" ] [
+ "123" "n" get validate value>>
+ ] unit-test
+] with-scope
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index bb0fc4b3dd..df46259c14 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables
combinators.cleave fry continuations math ;
IN: http.server.components
-SYMBOL: validation-failed?
-
SYMBOL: components
TUPLE: component id required default ;
@@ -30,16 +28,13 @@ SYMBOL: values
: validate ( value component -- result )
'[
- , ,
+ ,
over empty? [
[ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ]
bi
] [ validate* ] if
- ] [
- dup validation-error?
- [ validation-failed? on ] [ rethrow ] if
- ] recover ;
+ ] with-validator ;
: render-view ( component -- )
[ id>> value ] [ render-view* ] bi ;
@@ -215,7 +210,12 @@ M: number render-error*
! Text areas
TUPLE: text ;
-: <text> ( id -- component ) <string> text construct-delegate ;
+: <text> ( id -- component ) text <component> ;
+
+M: text validate* 2drop ;
+
+M: text render-view*
+ drop write ;
: render-textarea
<textarea
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
index 3ef2b6c863..d0785b0126 100755
--- a/extra/http/server/validators/validators-tests.factor
+++ b/extra/http/server/validators/validators-tests.factor
@@ -13,10 +13,10 @@ accessors ;
] unit-test
[ "slava@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
index 7eb5163d33..84f22b01f4 100755
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -5,21 +5,26 @@ math.parser assocs new-slots regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators
+SYMBOL: validation-failed?
+
TUPLE: validation-error value reason ;
-: validation-error ( value reason -- * )
- \ validation-error construct-boa throw ;
+C: <validation-error> validation-error
+
+: with-validator ( value quot -- result )
+ [ validation-failed? on <validation-error> ] recover ;
+ inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
- dup empty? [ "required" validation-error ] when ;
+ dup empty? [ "required" throw ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
- validation-error
+ throw
] [
drop
] if ;
@@ -27,35 +32,31 @@ TUPLE: validation-error value reason ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
- validation-error
+ throw
] [
drop
] if ;
: v-number ( str -- n )
- dup string>number [ ] [
- "must be a number" validation-error
- ] ?if ;
+ dup string>number [ ] [ "must be a number" throw ] ?if ;
: v-min-value ( x n -- x )
2dup < [
- [ "must be at least " % # ] "" make
- validation-error
+ [ "must be at least " % # ] "" make throw
] [
drop
] if ;
: v-max-value ( x n -- x )
2dup > [
- [ "must be no more than " % # ] "" make
- validation-error
+ [ "must be no more than " % # ] "" make throw
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
- [ drop ] [ "invalid " swap append validation-error ] if ;
+ [ drop ] [ "invalid " swap append throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
@@ -64,12 +65,12 @@ TUPLE: validation-error value reason ;
v-regexp ;
: v-captcha ( str -- str )
- dup empty? [ "must remain blank" validation-error ] unless ;
+ dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
dup "\r\n" seq-intersect empty?
- [ "must be a single line" validation-error ] unless ;
+ [ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
- [ "must be a single word" validation-error ] unless ;
+ [ "must be a single word" throw ] unless ;
From 7483dd721521fdeec2b03c6f13fc6c109c0bdfbc Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 14 Mar 2008 18:20:15 -0600
Subject: [PATCH 016/197] openssl.libcrypto: needed << ... >>
---
extra/openssl/libcrypto/libcrypto.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index 7b3ad2cf9f..bc65f72435 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -9,11 +9,13 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libcrypto
+<<
"libcrypto" {
{ [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
+>>
C-STRUCT: bio-method
{ "int" "type" }
From 7ae8324c38fa6f67e43ee9c2978c7a2d78d519d0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 14 Mar 2008 18:55:58 -0600
Subject: [PATCH 017/197] move pdf to unmaintained
---
{extra => unmaintained}/pdf/authors.txt | 0
{extra => unmaintained}/pdf/libhpdf/libhpdf.factor | 0
{extra => unmaintained}/pdf/pdf-tests.factor | 0
{extra => unmaintained}/pdf/pdf.factor | 0
{extra => unmaintained}/pdf/readme.txt | 0
5 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => unmaintained}/pdf/authors.txt (100%)
rename {extra => unmaintained}/pdf/libhpdf/libhpdf.factor (100%)
rename {extra => unmaintained}/pdf/pdf-tests.factor (100%)
rename {extra => unmaintained}/pdf/pdf.factor (100%)
rename {extra => unmaintained}/pdf/readme.txt (100%)
diff --git a/extra/pdf/authors.txt b/unmaintained/pdf/authors.txt
similarity index 100%
rename from extra/pdf/authors.txt
rename to unmaintained/pdf/authors.txt
diff --git a/extra/pdf/libhpdf/libhpdf.factor b/unmaintained/pdf/libhpdf/libhpdf.factor
similarity index 100%
rename from extra/pdf/libhpdf/libhpdf.factor
rename to unmaintained/pdf/libhpdf/libhpdf.factor
diff --git a/extra/pdf/pdf-tests.factor b/unmaintained/pdf/pdf-tests.factor
similarity index 100%
rename from extra/pdf/pdf-tests.factor
rename to unmaintained/pdf/pdf-tests.factor
diff --git a/extra/pdf/pdf.factor b/unmaintained/pdf/pdf.factor
similarity index 100%
rename from extra/pdf/pdf.factor
rename to unmaintained/pdf/pdf.factor
diff --git a/extra/pdf/readme.txt b/unmaintained/pdf/readme.txt
similarity index 100%
rename from extra/pdf/readme.txt
rename to unmaintained/pdf/readme.txt
From e347e3d7ac340a7e67f8cc6cc9de552534fab959 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 14 Mar 2008 20:52:08 -0500
Subject: [PATCH 018/197] fix typo in ffi
---
extra/db/sqlite/ffi/ffi.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 63bce0a8c3..1d356b1592 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -127,6 +127,6 @@ FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
From b6fece631400066aad83dbc6e83dc5af42a6ef1f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:22:29 -0500
Subject: [PATCH 019/197] Doc fixes
---
core/continuations/continuations-docs.factor | 4 +++-
core/kernel/kernel-docs.factor | 9 ++++++++-
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 81063031f9..7209b7ec4d 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -29,7 +29,9 @@ $nl
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
-{ $subsection "errors-post-mortem" } ;
+{ $subsection "errors-post-mortem" }
+"When Factor encouters a critical error, it calls the following word:"
+{ $subsection die } ;
ARTICLE: "continuations.private" "Continuation implementation details"
"A continuation is simply a tuple holding the contents of the five stacks:"
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 8e107975bb..0babb14fa7 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -429,7 +429,14 @@ $nl
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
HELP: die
-{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ;
+{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
+{ $notes
+ "The term FEP originates from the Lisp machines of old. According to the Jargon File,"
+ $nl
+ { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
+ $nl
+ { $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
+} ;
HELP: (clone) ( obj -- newobj )
{ $values { "obj" object } { "newobj" "a shallow copy" } }
From 234dfc5705e3758b38e025215552d0fb18486851 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:22:47 -0500
Subject: [PATCH 020/197] Persistent sessions
---
extra/assocs/lib/lib.factor | 10 +-
extra/http/client/client-tests.factor | 1 +
extra/http/http.factor | 1 +
.../http/server/actions/actions-tests.factor | 15 ++-
extra/http/server/actions/actions.factor | 11 +-
extra/http/server/auth/login/login.factor | 4 +-
.../auth/providers/assoc/assoc-tests.factor | 2 +-
.../server/auth/providers/assoc/assoc.factor | 12 +-
.../server/auth/providers/db/db-tests.factor | 7 +-
extra/http/server/auth/providers/db/db.factor | 13 +-
.../server/auth/providers/null/null.factor | 12 +-
.../server/auth/providers/providers.factor | 2 +-
extra/http/server/callbacks/callbacks.factor | 2 +-
.../server/components/components-tests.factor | 8 ++
.../http/server/components/components.factor | 7 +-
extra/http/server/server.factor | 44 +++---
.../server/sessions/sessions-tests.factor | 95 +++++++++++--
extra/http/server/sessions/sessions.factor | 125 +++++++++---------
.../sessions/storage/assoc/assoc.factor | 38 ++++++
.../sessions/storage/db/db-tests.factor | 24 ++++
.../http/server/sessions/storage/db/db.factor | 52 ++++++++
.../server/sessions/storage/storage.factor | 14 ++
.../server/validators/validators-tests.factor | 3 +-
.../http/server/validators/validators.factor | 3 +
24 files changed, 366 insertions(+), 139 deletions(-)
create mode 100755 extra/http/server/sessions/storage/assoc/assoc.factor
create mode 100755 extra/http/server/sessions/storage/db/db-tests.factor
create mode 100755 extra/http/server/sessions/storage/db/db.factor
create mode 100755 extra/http/server/sessions/storage/storage.factor
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index d2eb42a117..2500940373 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -1,4 +1,5 @@
-USING: arrays assocs kernel vectors sequences namespaces ;
+USING: arrays assocs kernel vectors sequences namespaces
+random math.parser ;
IN: assocs.lib
: >set ( seq -- hash )
@@ -38,3 +39,10 @@ IN: assocs.lib
: 2seq>assoc ( keys values exemplar -- assoc )
>r 2array flip r> assoc-like ;
+
+: generate-key ( assoc -- str )
+ >r random-256 >hex r>
+ 2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+ dup generate-key [ swap set-at ] keep ;
diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor
index 661f63ab59..0f684f782a 100755
--- a/extra/http/client/client-tests.factor
+++ b/extra/http/client/client-tests.factor
@@ -18,6 +18,7 @@ tuple-syntax namespaces ;
port: 80
version: "1.1"
cookies: V{ }
+ header: H{ }
}
] [
[
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 4dd433f85d..421a409639 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -180,6 +180,7 @@ cookies ;
request construct-empty
"1.1" >>version
http-port >>port
+ H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies ;
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
index 45f7ff385d..c604b8a427 100755
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -1,11 +1,16 @@
IN: http.server.actions.tests
-USING: http.server.actions tools.test math math.parser
-multiline namespaces http io.streams.string http.server
-sequences accessors ;
+USING: http.server.actions http.server.validators
+tools.test math math.parser multiline namespaces http
+io.streams.string http.server sequences accessors ;
+
+[
+ "a" [ v-number ] { { "a" "123" } } validate-param
+ [ 123 ] [ "a" get ] unit-test
+] with-scope
<action>
[ "a" get "b" get + ] >>display
- { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
+ { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
STRING: action-request-test-1
@@ -23,7 +28,7 @@ blah
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
- { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+ { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 7bee96edce..91671392c7 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces
-combinators.cleave fry continuations ;
+combinators.cleave fry continuations locals ;
IN: http.server.actions
SYMBOL: +path+
@@ -17,12 +17,13 @@ TUPLE: action init display submit get-params post-params ;
[ <400> ] >>display
[ <400> ] >>submit ;
-: validate-param ( name validator assoc -- error? )
- swap pick
- >r >r at r> with-validator swap r> set ;
+:: validate-param ( name validator assoc -- )
+ name assoc at validator with-validator name set ; inline
: action-params ( validators -- error? )
- [ params get validate-param ] { } assoc>map [ ] contains? ;
+ validation-failed? off
+ params get '[ , validate-param ] assoc-each
+ validation-failed? get ;
: handle-get ( -- response )
action get get-params>> action-params [ <400> ] [
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 8842e1639e..a1c99f749c 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -173,7 +173,7 @@ SYMBOL: previous-page
dup users update-user
logged-in-user sset
- previous-page sget dup [ f <permanent-redirect> ] when
+ previous-page sget f <permanent-redirect>
] >>submit
] ;
@@ -347,7 +347,7 @@ M: login call-responder ( path responder -- response )
swap <protected> >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
- no >>users ;
+ no-users >>users ;
! ! ! Configuration
diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor
index 12c799816d..90ba6e0d53 100755
--- a/extra/http/server/auth/providers/assoc/assoc-tests.factor
+++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor
@@ -3,7 +3,7 @@ USING: http.server.auth.providers
http.server.auth.providers.assoc tools.test
namespaces accessors kernel ;
-<in-memory> "provider" set
+<users-in-memory> "provider" set
[ t ] [
<user>
diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor
index 8433e54fda..e8ab908406 100755
--- a/extra/http/server/auth/providers/assoc/assoc.factor
+++ b/extra/http/server/auth/providers/assoc/assoc.factor
@@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc
USING: new-slots accessors assocs kernel
http.server.auth.providers ;
-TUPLE: in-memory assoc ;
+TUPLE: users-in-memory assoc ;
-: <in-memory> ( -- provider )
- H{ } clone in-memory construct-boa ;
+: <users-in-memory> ( -- provider )
+ H{ } clone users-in-memory construct-boa ;
-M: in-memory get-user ( username provider -- user/f )
+M: users-in-memory get-user ( username provider -- user/f )
assoc>> at ;
-M: in-memory update-user ( user provider -- ) 2drop ;
+M: users-in-memory update-user ( user provider -- ) 2drop ;
-M: in-memory new-user ( user provider -- user/f )
+M: users-in-memory new-user ( user provider -- user/f )
>r dup username>> r> assoc>>
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor
index 247359aea4..1ee7278163 100755
--- a/extra/http/server/auth/providers/db/db-tests.factor
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@@ -4,12 +4,11 @@ http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;
-from-db "provider" set
+users-in-db "provider" set
"auth-test.db" temp-file sqlite-db [
- [ user drop-table ] ignore-errors
- [ user create-table ] ignore-errors
+ init-users-table
[ t ] [
<user>
@@ -32,7 +31,7 @@ from-db "provider" set
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
- [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
+ [ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
index c9e1328052..aec64d3384 100755
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.tuples db.types new-slots accessors
-http.server.auth.providers kernel continuations ;
+http.server.auth.providers kernel continuations
+singleton ;
IN: http.server.auth.providers.db
user "USERS"
@@ -16,20 +17,18 @@ user "USERS"
: init-users-table user ensure-table ;
-TUPLE: from-db ;
-
-: from-db T{ from-db } ;
+SINGLETON: users-in-db
: find-user ( username -- user )
<user>
swap >>username
select-tuple ;
-M: from-db get-user
+M: users-in-db get-user
drop
find-user ;
-M: from-db new-user
+M: users-in-db new-user
drop
[
dup username>> find-user [
@@ -39,5 +38,5 @@ M: from-db new-user
] if
] with-transaction ;
-M: from-db update-user
+M: users-in-db update-user
drop update-tuple ;
diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor
index 7b8bfc627c..30f6dbd06e 100755
--- a/extra/http/server/auth/providers/null/null.factor
+++ b/extra/http/server/auth/providers/null/null.factor
@@ -3,14 +3,12 @@
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
-! Named "no" because we can say no >>users
+TUPLE: no-users ;
-TUPLE: no ;
+: no-users T{ no-users } ;
-: no T{ no } ;
+M: no-users get-user 2drop f ;
-M: no get-user 2drop f ;
+M: no-users new-user 2drop f ;
-M: no new-user 2drop f ;
-
-M: no update-user 2drop ;
+M: no-users update-user 2drop ;
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index 74620a4f5d..cd9cc995c7 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -22,7 +22,7 @@ GENERIC: new-user ( user provider -- user/f )
user [
user
password >>password
- provider dup update-user
+ dup provider update-user
] [ f ] if
] ;
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
index ac03e0efc8..45a6ff85f8 100755
--- a/extra/http/server/callbacks/callbacks.factor
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -4,7 +4,7 @@
USING: html http http.server io kernel math namespaces
continuations calendar sequences assocs new-slots hashtables
accessors arrays alarms quotations combinators
-combinators.cleave fry ;
+combinators.cleave fry assocs.lib ;
IN: http.server.callbacks
SYMBOL: responder
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
index 83ae7b0118..09d31202c5 100755
--- a/extra/http/server/components/components-tests.factor
+++ b/extra/http/server/components/components-tests.factor
@@ -98,4 +98,12 @@ TUPLE: test-tuple text number more-text ;
[ "123" ] [
"123" "n" get validate value>>
] unit-test
+
+ [ ] [ "n" get t >>integer drop ] unit-test
+
+ [ 3 ] [
+ "3" "n" get validate
+ ] unit-test
] with-scope
+
+[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index df46259c14..02c992651a 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -187,15 +187,16 @@ M: password render-error*
render-edit* render-error ;
! Number fields
-TUPLE: number min-value max-value ;
+TUPLE: number min-value max-value integer ;
: <number> ( id -- component ) number <component> ;
M: number validate*
[ v-number ] [
+ [ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
- bi
+ tri
] bi* ;
M: number render-view*
@@ -212,7 +213,7 @@ TUPLE: text ;
: <text> ( id -- component ) text <component> ;
-M: text validate* 2drop ;
+M: text validate* drop ;
M: text render-view*
drop write ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 60bb5d921d..ce6a1244cb 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ;
: <dispatcher> ( -- dispatcher )
404-responder get H{ } clone dispatcher construct-boa ;
-: set-main ( dispatcher name -- dispatcher )
- '[ , f <permanent-redirect> ] <trivial-responder>
- >>default ;
-
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
@@ -124,28 +120,36 @@ TUPLE: dispatcher default responders ;
M: dispatcher call-responder ( path dispatcher -- response )
over [
- 2dup find-responder call-responder [
- 2nip
- ] [
- default>> [
- call-responder
- ] [
- drop f
- ] if*
- ] if*
+ find-responder call-responder
] [
2drop redirect-with-/
] if ;
+: <webapp> ( class -- dispatcher )
+ <dispatcher> swap construct-delegate ; inline
+
+TUPLE: vhost-dispatcher default responders ;
+
+: <vhost-dispatcher> ( -- dispatcher )
+ 404-responder get H{ } clone vhost-dispatcher construct-boa ;
+
+: find-vhost ( dispatcher -- responder )
+ request get host>> over responders>> at*
+ [ nip ] [ drop default>> ] if ;
+
+M: vhost-dispatcher call-responder ( path dispatcher -- response )
+ find-vhost call-responder ;
+
+: set-main ( dispatcher name -- dispatcher )
+ '[ , f <permanent-redirect> ] <trivial-responder>
+ >>default ;
+
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder ] keep set-main ;
-: <webapp> ( class -- dispatcher )
- <dispatcher> swap construct-delegate ; inline
-
SYMBOL: main-responder
main-responder global
@@ -219,11 +223,3 @@ SYMBOL: exit-continuation
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main
-
-! Utility
-: generate-key ( assoc -- str )
- >r random-256 >hex r>
- 2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
- dup generate-key [ swap set-at ] keep ;
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 5530b04611..a6a42f9129 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -1,6 +1,8 @@
IN: http.server.sessions.tests
-USING: tools.test http.server.sessions math namespaces
-kernel accessors ;
+USING: tools.test http http.server.sessions
+http.server.sessions.storage http.server.sessions.storage.assoc
+http.server math namespaces kernel accessors prettyprint
+io.streams.string splitting destructors ;
[ H{ } ] [ H{ } add-session-id ] unit-test
@@ -12,7 +14,16 @@ C: <foo> foo
M: foo init-session* drop 0 "x" sset ;
-f <session> "123" >>id [
+M: foo call-responder
+ 2drop
+ "x" [ 1+ ] schange
+ "text/html" <content> [ "x" sget pprint ] >>body ;
+
+[
+ "123" session-id set
+ H{ } clone session set
+ session-changed? off
+
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
@@ -22,22 +33,88 @@ f <session> "123" >>id [
[ ] [ "x" [ 1- ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
-] with-session
+
+ [ t ] [ session-changed? get ] unit-test
+] with-scope
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
+ <sessions-in-memory> >>sessions
"manager" set
] unit-test
[ { 5 0 } ] [
[
- "manager" get new-session
- dup "manager" get get-session [ 5 "a" sset ] with-session
- dup "manager" get get-session [ "a" sget , ] with-session
- dup "manager" get get-session [ "x" sget , ] with-session
- "manager" get get-session delete-session
+ "manager" get begin-session drop
+ dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
+ dup "manager" get sessions>> get-session [ "a" sget , ] with-session
+ dup "manager" get sessions>> get-session [ "x" sget , ] with-session
+ "manager" get sessions>> get-session
+ "manager" get sessions>> delete-session
] { } make
] unit-test
+
+[ ] [
+ <request>
+ "GET" >>method
+ request set
+ "/etc" "manager" get call-responder
+ response set
+] unit-test
+
+[ 307 ] [ response get code>> ] unit-test
+
+[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
+
+: url-responder-mock-test
+ [
+ <request>
+ "GET" >>method
+ "id" get session-id-key set-query-param
+ "/" >>path
+ request set
+ "/" "manager" get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+[ "1" ] [ url-responder-mock-test ] unit-test
+[ "2" ] [ url-responder-mock-test ] unit-test
+[ "3" ] [ url-responder-mock-test ] unit-test
+[ "4" ] [ url-responder-mock-test ] unit-test
+
+[ ] [
+ <foo> <cookie-sessions>
+ <sessions-in-memory> >>sessions
+ "manager" set
+] unit-test
+
+[
+ <request>
+ "GET" >>method
+ "/" >>path
+ request set
+ "/etc" "manager" get call-responder response set
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
+ response get
+] with-destructors
+response set
+
+[ ] [ response get cookies>> "cookies" set ] unit-test
+
+: cookie-responder-mock-test
+ [
+ <request>
+ "GET" >>method
+ "cookies" get >>cookies
+ "/" >>path
+ request set
+ "/" "manager" get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+[ "2" ] [ cookie-responder-mock-test ] unit-test
+[ "3" ] [ cookie-responder-mock-test ] unit-test
+[ "4" ] [ cookie-responder-mock-test ] unit-test
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index 260c80914e..76f022e28c 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
-boxes alarms new-slots accessors http http.server
+new-slots accessors http http.server
+http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry combinators.cleave
-html.elements ;
+html.elements symbols continuations destructors ;
IN: http.server.sessions
! ! ! ! ! !
@@ -17,56 +18,48 @@ M: dispatcher init-session* drop ;
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
- >r H{ } clone session-manager construct-boa r>
- construct-delegate ; inline
+ >r <sessions-in-memory> session-manager construct-boa
+ r> construct-delegate ; inline
-TUPLE: session manager id namespace alarm ;
+SYMBOLS: session session-id session-changed? ;
-: <session> ( manager -- session )
- f H{ } clone <box> \ session construct-boa ;
+: sget ( key -- value )
+ session get at ;
-: timeout ( -- dt ) 20 minutes ;
+: sset ( value key -- )
+ session get set-at
+ session-changed? on ;
-: cancel-timeout ( session -- )
- alarm>> [ cancel-alarm ] if-box? ;
+: schange ( key quot -- )
+ session get swap change-at
+ session-changed? on ; inline
-: delete-session ( session -- )
- [ cancel-timeout ]
- [ dup manager>> sessions>> delete-at ]
- bi ;
+: sessions session-manager get sessions>> ;
-: touch-session ( session -- session )
- [ cancel-timeout ]
- [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
- [ ]
- tri ;
+: managed-responder session-manager get responder>> ;
-: session ( -- assoc ) \ session get namespace>> ;
+: init-session ( managed -- session )
+ H{ } clone [ session [ init-session* ] with-variable ] keep ;
-: sget ( key -- value ) session at ;
+: begin-session ( responder -- id session )
+ [ responder>> init-session ] [ sessions>> ] bi
+ [ new-session ] [ drop ] 2bi ;
-: sset ( value key -- ) session set-at ;
+! Destructor
+TUPLE: session-saver id session ;
-: schange ( key quot -- ) session swap change-at ; inline
+C: <session-saver> session-saver
-: init-session ( session -- session )
- dup dup \ session [
- manager>> responder>> init-session*
- ] with-variable ;
+M: session-saver dispose
+ session-changed? get [
+ [ session>> ] [ id>> ] bi
+ sessions update-session
+ ] [ drop ] if ;
-: new-session ( responder -- id )
- [ <session> init-session touch-session ]
- [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
- bi id>> ;
-
-: get-session ( id responder -- session/f )
- sessions>> at* [ touch-session ] when ;
-
-: call-responder/session ( path responder session -- response )
- \ session set responder>> call-responder ;
-
-: sessions ( -- manager/f )
- \ session get dup [ manager>> ] when ;
+: call-responder/session ( path responder id session -- response )
+ [ <session-saver> add-always-destructor ]
+ [ [ session-id set ] [ session set ] bi* ] 2bi
+ [ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: null-sessions ;
@@ -74,56 +67,64 @@ TUPLE: null-sessions ;
null-sessions <session-manager> ;
M: null-sessions call-responder ( path responder -- response )
- dup <session> call-responder/session ;
+ H{ } clone f call-responder/session ;
TUPLE: url-sessions ;
: <url-sessions> ( responder -- responder' )
url-sessions <session-manager> ;
-: sess-id "factorsessid" ;
+: session-id-key "factorsessid" ;
-: current-session ( responder -- session )
- >r request-params sess-id swap at r> get-session ;
+: current-url-session ( responder -- id/f session/f )
+ [ request-params session-id-key swap at ] [ sessions>> ] bi*
+ [ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
- \ session get [ id>> sess-id associate union ] when* ;
+ session-id get [ session-id-key associate union ] when* ;
: session-form-field ( -- )
<input
- "hidden" =type
- sess-id =id
- sess-id =name
- \ session get id>> =value
+ "hidden" =type
+ session-id-key =id
+ session-id-key =name
+ session-id get =value
input/> ;
+: new-url-session ( responder -- response )
+ [ f ] [ begin-session drop session-id-key associate ] bi*
+ <temporary-redirect> ;
+
M: url-sessions call-responder ( path responder -- response )
[ add-session-id ] link-hook set
[ session-form-field ] form-hook set
- dup current-session [
+ dup current-url-session dup [
call-responder/session
] [
- nip
- f swap new-session sess-id associate <temporary-redirect>
- ] if* ;
+ 2drop nip new-url-session
+ ] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
-: get-session-cookie ( responder -- cookie )
- request get sess-id get-cookie
- [ value>> swap get-session ] [ drop f ] if* ;
+: current-cookie-session ( responder -- id namespace/f )
+ request get session-id-key get-cookie dup
+ [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
: <session-cookie> ( id -- cookie )
- sess-id <cookie> ;
+ session-id-key <cookie> ;
+
+: call-responder/new-session ( path responder -- response )
+ dup begin-session
+ [ call-responder/session ]
+ [ drop <session-cookie> ] 2bi
+ put-cookie ;
M: cookie-sessions call-responder ( path responder -- response )
- dup get-session-cookie [
+ dup current-cookie-session dup [
call-responder/session
] [
- dup new-session
- [ over get-session call-responder/session ] keep
- <session-cookie> put-cookie
- ] if* ;
+ 2drop call-responder/new-session
+ ] if ;
diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor
new file mode 100755
index 0000000000..1339e3c867
--- /dev/null
+++ b/extra/http/server/sessions/storage/assoc/assoc.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs assocs.lib new-slots accessors
+http.server.sessions.storage combinators.cleave alarms kernel
+fry http.server ;
+IN: http.server.sessions.storage.assoc
+
+TUPLE: sessions-in-memory sessions alarms ;
+
+: <sessions-in-memory> ( -- storage )
+ H{ } clone H{ } clone sessions-in-memory construct-boa ;
+
+: cancel-session-timeout ( id storage -- )
+ alarms>> at [ cancel-alarm ] when* ;
+
+: touch-session ( id storage -- )
+ [ cancel-session-timeout ]
+ [ '[ , , delete-session ] timeout later ]
+ [ alarms>> set-at ]
+ 2tri ;
+
+M: sessions-in-memory get-session ( id storage -- namespace )
+ [ sessions>> at ] [ touch-session ] 2bi ;
+
+M: sessions-in-memory update-session ( namespace id storage -- )
+ [ sessions>> set-at ]
+ [ touch-session ]
+ 2bi ;
+
+M: sessions-in-memory delete-session ( id storage -- )
+ [ sessions>> delete-at ]
+ [ cancel-session-timeout ]
+ 2bi ;
+
+M: sessions-in-memory new-session ( namespace storage -- id )
+ [ sessions>> set-at-unique ]
+ [ [ touch-session ] [ drop ] 2bi ]
+ bi ;
diff --git a/extra/http/server/sessions/storage/db/db-tests.factor b/extra/http/server/sessions/storage/db/db-tests.factor
new file mode 100755
index 0000000000..4e6ae8a9b4
--- /dev/null
+++ b/extra/http/server/sessions/storage/db/db-tests.factor
@@ -0,0 +1,24 @@
+IN: http.server.sessions.storage.db
+USING: http.server.sessions.storage
+http.server.sessions.storage.db namespaces io.files
+db.sqlite db accessors math tools.test kernel assocs
+sequences ;
+
+sessions-in-db "storage" set
+
+"auth-test.db" temp-file sqlite-db [
+ [ ] [ init-sessions-table ] unit-test
+
+ [ f ] [ H{ } "storage" get new-session empty? ] unit-test
+
+ H{ } "storage" get new-session "id" set
+
+ "id" get "storage" get get-session "session" set
+ "a" "b" "session" get set-at
+
+ "session" get "id" get "storage" get update-session
+
+ [ H{ { "b" "a" } } ] [
+ "id" get "storage" get get-session
+ ] unit-test
+] with-db
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
new file mode 100755
index 0000000000..6ef655bde2
--- /dev/null
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -0,0 +1,52 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs new-slots accessors http.server.sessions.storage
+alarms kernel http.server db.tuples db.types singleton
+combinators.cleave math.parser ;
+IN: http.server.sessions.storage.db
+
+SINGLETON: sessions-in-db
+
+TUPLE: session id namespace ;
+
+session "SESSIONS"
+{
+ { "id" "ID" INTEGER +native-id+ }
+ { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: init-sessions-table session ensure-table ;
+
+: <session> ( id -- session )
+ session construct-empty
+ swap dup [ string>number ] when >>id ;
+
+USING: namespaces io prettyprint ;
+M: sessions-in-db get-session ( id storage -- namespace/f )
+ global [ "get " write over print flush ] bind
+ drop
+ dup [
+ <session>
+ select-tuple dup [ namespace>> ] when global [ dup . ] bind
+ ] when ;
+
+M: sessions-in-db update-session ( namespace id storage -- )
+ global [ "update " write over print flush ] bind
+ drop
+ <session>
+ swap global [ dup . ] bind >>namespace
+ dup update-tuple
+ id>> <session> select-tuple global [ . flush ] bind
+ ;
+
+M: sessions-in-db delete-session ( id storage -- )
+ drop
+ <session>
+ delete-tuple ;
+
+M: sessions-in-db new-session ( namespace storage -- id )
+ global [ "new " print flush ] bind
+ drop
+ f <session>
+ swap global [ dup . ] bind >>namespace
+ [ insert-tuple ] [ id>> number>string ] bi ;
diff --git a/extra/http/server/sessions/storage/storage.factor b/extra/http/server/sessions/storage/storage.factor
new file mode 100755
index 0000000000..df96c815c7
--- /dev/null
+++ b/extra/http/server/sessions/storage/storage.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar ;
+IN: http.server.sessions.storage
+
+: timeout 20 minutes ;
+
+GENERIC: get-session ( id storage -- namespace )
+
+GENERIC: update-session ( namespace id storage -- )
+
+GENERIC: delete-session ( id storage -- )
+
+GENERIC: new-session ( namespace storage -- id )
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
index d0785b0126..82827ac450 100755
--- a/extra/http/server/validators/validators-tests.factor
+++ b/extra/http/server/validators/validators-tests.factor
@@ -2,7 +2,8 @@ IN: http.server.validators.tests
USING: kernel sequences tools.test http.server.validators
accessors ;
-[ "foo" v-number ] [ validation-error? ] must-fail-with
+[ "foo" v-number ] must-fail
+[ 123 ] [ "123" v-number ] unit-test
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
index 84f22b01f4..539a58d19f 100755
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -40,6 +40,9 @@ C: <validation-error> validation-error
: v-number ( str -- n )
dup string>number [ ] [ "must be a number" throw ] ?if ;
+: v-integer ( n -- n )
+ dup integer? [ "must be an integer" throw ] unless ;
+
: v-min-value ( x n -- x )
2dup < [
[ "must be at least " % # ] "" make throw
From e3f7cf36e27514dc299e680b93c168b589da9a30 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:22:57 -0500
Subject: [PATCH 021/197] Fix Windows file-info
---
extra/io/windows/files/files.factor | 2 +-
extra/io/windows/windows.factor | 7 ++-----
2 files changed, 3 insertions(+), 6 deletions(-)
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 2180ff7901..35aaf456a3 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -7,7 +7,7 @@ sequences namespaces words symbols ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
-+directory+ +archive+ +device+ +normal+ +temporary+
++archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index f6a9dd451f..dac55664a4 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -76,11 +76,8 @@ M: win32-file close-handle ( handle -- )
] when drop ;
: open-append ( path -- handle length )
- dup file-info file-info-size dup [
- >r (open-append) r> 2dup set-file-pointer
- ] [
- drop open-write
- ] if ;
+ [ dup file-info file-info-size ] [ drop 0 ] recover
+ >r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
From 5dac0ac8896e6e3352c30bc43b866e2cd81479b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:23:10 -0500
Subject: [PATCH 022/197] Add unit test
---
core/io/files/files-tests.factor | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index e2eeef6528..e347e3e3d6 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,6 +1,10 @@
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
+[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
+[ ] [ "blahblah" temp-file make-directory ] unit-test
+[ t ] [ "blahblah" temp-file directory? ] unit-test
+
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
@@ -123,3 +127,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
+
+[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
+
+[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
From 65a91d549e126f490d31dfafad36451d90952a74 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:23:47 -0500
Subject: [PATCH 023/197] Fix redefinition of generics to symbols
---
extra/symbols/symbols-tests.factor | 10 +++++++++-
extra/symbols/symbols.factor | 7 ++++---
2 files changed, 13 insertions(+), 4 deletions(-)
mode change 100644 => 100755 extra/symbols/symbols-tests.factor
mode change 100644 => 100755 extra/symbols/symbols.factor
diff --git a/extra/symbols/symbols-tests.factor b/extra/symbols/symbols-tests.factor
old mode 100644
new mode 100755
index 84a61509c8..0eacbbfd38
--- a/extra/symbols/symbols-tests.factor
+++ b/extra/symbols/symbols-tests.factor
@@ -1,7 +1,15 @@
-USING: kernel symbols tools.test ;
+USING: kernel symbols tools.test parser generic words ;
IN: symbols.tests
[ ] [ SYMBOLS: a b c ; ] unit-test
[ a ] [ a ] unit-test
[ b ] [ b ] unit-test
[ c ] [ c ] unit-test
+
+DEFER: blah
+
+[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test
+[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test
+
+[ f ] [ \ blah generic? ] unit-test
+[ t ] [ \ blah symbol? ] unit-test
diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor
old mode 100644
new mode 100755
index 8e074f4163..f6254f19de
--- a/extra/symbols/symbols.factor
+++ b/extra/symbols/symbols.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser sequences words ;
+USING: parser sequences words kernel ;
IN: symbols
: SYMBOLS:
- ";" parse-tokens [ create-in define-symbol ] each ;
+ ";" parse-tokens
+ [ create-in dup reset-generic define-symbol ] each ;
parsing
From 3d9f6137190594c825f05abfbf60de1a6487b621 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:24:00 -0500
Subject: [PATCH 024/197] Log files are utf8
---
extra/logging/server/server.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index d181ab8a16..896a46858b 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -3,7 +3,7 @@
USING: namespaces kernel io calendar sequences io.files
io.sockets continuations prettyprint assocs math.parser
words debugger math combinators concurrency.messaging
-threads arrays init math.ranges strings calendar.format
+threads arrays init math.ranges strings calendar.format
io.encodings.ascii ;
IN: logging.server
@@ -21,7 +21,7 @@ SYMBOL: log-files
: open-log-stream ( service -- stream )
log-path
dup make-directories
- 1 log# ascii <file-appender> ;
+ 1 log# utf8 <file-appender> ;
: log-stream ( service -- stream )
log-files get [ open-log-stream ] cache ;
From 129320c65b8fd12ae5260effcfed5c5f745b061b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 06:44:14 -0500
Subject: [PATCH 025/197] Fix bootstrap
---
extra/logging/server/server.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index 896a46858b..372216c45e 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -4,7 +4,7 @@ USING: namespaces kernel io calendar sequences io.files
io.sockets continuations prettyprint assocs math.parser
words debugger math combinators concurrency.messaging
threads arrays init math.ranges strings calendar.format
-io.encodings.ascii ;
+io.encodings.utf8 ;
IN: logging.server
: log-root ( -- string )
From 86ed87da0ce01b354d38fb4d7a3ccf91e328aa3c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 07:57:38 -0500
Subject: [PATCH 026/197] Get some db words to infer
---
extra/db/db-tests.factor | 5 +++++
extra/db/postgresql/postgresql.factor | 4 ++--
extra/db/sqlite/sqlite.factor | 2 +-
extra/db/tuples/tuples-tests.factor | 6 ++++++
extra/db/tuples/tuples.factor | 2 +-
extra/namespaces/lib/lib-tests.factor | 6 ++++++
extra/namespaces/lib/lib.factor | 24 ++++++++++++++++--------
extra/sequences/lib/lib-tests.factor | 3 +++
extra/sequences/lib/lib.factor | 9 +++++----
9 files changed, 45 insertions(+), 16 deletions(-)
create mode 100755 extra/db/db-tests.factor
create mode 100755 extra/namespaces/lib/lib-tests.factor
mode change 100644 => 100755 extra/namespaces/lib/lib.factor
diff --git a/extra/db/db-tests.factor b/extra/db/db-tests.factor
new file mode 100755
index 0000000000..9c32f9e326
--- /dev/null
+++ b/extra/db/db-tests.factor
@@ -0,0 +1,5 @@
+IN: db.tests
+USING: tools.test db kernel ;
+
+{ 1 0 } [ [ drop ] query-each ] must-infer-as
+{ 1 1 } [ [ ] query-map ] must-infer-as
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 26b6cbe75c..b2042c98bd 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -119,8 +119,8 @@ M: postgresql-db bind% ( spec -- )
: postgresql-make ( class quot -- )
>r sql-props r>
- [ postgresql-counter off ] swap compose
- { "" { } { } } nmake <postgresql-statement> ;
+ [ postgresql-counter off call ] { "" { } { } } nmake
+ <postgresql-statement> ; inline
: create-table-sql ( class -- statement )
[
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 9a9db74401..3466301390 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -98,7 +98,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
- { "" { } { } } nmake <simple-statement> ;
+ { "" { } { } } nmake <simple-statement> ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 4c47066d35..ba6441bc53 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -239,3 +239,9 @@ TUPLE: exam id name score ;
;
! [ test-ranges ] test-sqlite
+
+\ insert-tuple must-infer
+\ update-tuple must-infer
+\ delete-tuple must-infer
+\ select-tuple must-infer
+\ define-persistent must-infer
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 82147a2efa..d50e42c0fb 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -36,7 +36,7 @@ HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
-HOOK: <select-by-slots-statement> db ( tuple -- tuple )
+HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
diff --git a/extra/namespaces/lib/lib-tests.factor b/extra/namespaces/lib/lib-tests.factor
new file mode 100755
index 0000000000..20769e161c
--- /dev/null
+++ b/extra/namespaces/lib/lib-tests.factor
@@ -0,0 +1,6 @@
+IN: namespaces.lib.tests
+USING: namespaces.lib tools.test ;
+
+[ ] [ [ ] { } nmake ] unit-test
+
+[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor
old mode 100644
new mode 100755
index 76ba0ac63e..47b6b33a9a
--- a/extra/namespaces/lib/lib.factor
+++ b/extra/namespaces/lib/lib.factor
@@ -2,7 +2,7 @@
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math sequences.lib ;
+ assocs.lib math.parser math sequences.lib locals ;
IN: namespaces.lib
@@ -42,11 +42,19 @@ SYMBOL: building-seq
: 4% 4 n% ;
: 4# 4 n# ;
-: nmake ( quot exemplars -- seqs )
- dup length dup zero? [ 1+ ] when
- [
+MACRO:: nmake ( quot exemplars -- )
+ [let | n [ exemplars length ] |
[
- [ drop 1024 swap new-resizable ] 2map
- [ building-seq set call ] keep
- ] 2keep >r [ like ] 2map r> firstn
- ] with-scope ;
+ [
+ exemplars
+ [ 0 swap new-resizable ] map
+ building-seq set
+
+ quot call
+
+ building-seq get
+ exemplars [ like ] 2map
+ n firstn
+ ] with-scope
+ ]
+ ] ;
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index b19c2f39c9..6e6a924382 100755
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -79,3 +79,6 @@ IN: sequences.lib.tests
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
+
+[ ] [ { } 0 firstn ] unit-test
+[ "a" ] [ { "a" } 1 firstn ] unit-test
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 13e8eb949f..a6b6b73148 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -4,7 +4,7 @@
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros
-assocs.lib ;
+assocs.lib quotations ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@@ -20,8 +20,9 @@ IN: sequences.lib
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: firstn ( n -- )
- [ [ swap nth ] curry
- [ keep ] curry ] map concat [ drop ] compose ;
+ [ [ swap nth ] curry [ keep ] curry ] map
+ concat >quotation
+ [ drop ] compose ;
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
@@ -193,7 +194,7 @@ USE: continuations
: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
: accumulator ( quot -- quot vec )
- V{ } clone [ [ push ] curry compose ] keep ;
+ V{ } clone [ [ push ] curry compose ] keep ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 8d617d8604dfdcbcbd235c5287e37d76a201a763 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 15 Mar 2008 07:57:52 -0500
Subject: [PATCH 027/197] Fix unit test
---
extra/http/server/auth/providers/assoc/assoc-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor
index 90ba6e0d53..ae4c5d051f 100755
--- a/extra/http/server/auth/providers/assoc/assoc-tests.factor
+++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor
@@ -26,7 +26,7 @@ namespaces accessors kernel ;
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
-[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
+[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
From d8e8fb253ac04d5dd524db1c2ae416f749baba96 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 15 Mar 2008 15:07:53 -0600
Subject: [PATCH 028/197] Add docs for OpenGL Geometric primitives
---
extra/opengl/gl/gl-docs.factor | 23 +++++++++++++++++++++++
extra/opengl/opengl-docs.factor | 6 +++++-
extra/opengl/opengl.factor | 2 +-
3 files changed, 29 insertions(+), 2 deletions(-)
create mode 100644 extra/opengl/gl/gl-docs.factor
diff --git a/extra/opengl/gl/gl-docs.factor b/extra/opengl/gl/gl-docs.factor
new file mode 100644
index 0000000000..6efe865ddd
--- /dev/null
+++ b/extra/opengl/gl/gl-docs.factor
@@ -0,0 +1,23 @@
+
+USING: help.syntax help.markup ;
+
+IN: opengl.gl
+
+ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
+
+ { $table { { $link GL_POINTS } "individual points" }
+ { { $link GL_LINES } "pairs of vertices interpreted as indivisual line segments" }
+ { { $link GL_LINE_STRIP } "series of connected line segments" }
+ { { $link GL_LINE_LOOP } "same as above, with a segment added between last and first vertices" }
+ { { $link GL_TRIANGLES } "triples of vertices interpreted as triangles" }
+ { { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
+ { { $link GL_TRIANGLE_FAN } "linked fan of triangles" }
+ { { $link GL_QUADS } "quadruples of vertices interpreted as four-sided polygons" }
+ { { $link GL_QUAD_STRIP } "linked strip of quadrilaterals" }
+ { { $link GL_POLYGON } "boundary of a simple, convex polygon" } }
+
+;
+
+HELP: glBegin
+ { $values { "mode"
+ { "One of the " { $link "opengl-geometric-primitives" } } } } ;
\ No newline at end of file
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index 97120237ec..5b1ee0d565 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -10,7 +10,11 @@ HELP: gl-error
{ $description "If the most recent OpenGL call resulted in an error, print the error to the " { $link stdio } " stream." } ;
HELP: do-state
-{ $values { "what" integer } { "quot" quotation } }
+ {
+ $values
+ { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
+ { "quot" quotation }
+ }
{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
HELP: do-enabled
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 5afb6ef070..08e3cb204b 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -25,7 +25,7 @@ IN: opengl
"GL error: " over gluErrorString append throw
] unless drop ;
-: do-state ( what quot -- )
+: do-state ( mode quot -- )
swap glBegin call glEnd ; inline
: do-enabled ( what quot -- )
From 5ab0588e46b0e2220a852936ec512bbf319d8d16 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 15 Mar 2008 15:28:12 -0600
Subject: [PATCH 029/197] Add more opengl.gl help
---
extra/opengl/gl/gl-docs.factor | 52 +++++++++++++++++++++++++++-------
1 file changed, 42 insertions(+), 10 deletions(-)
diff --git a/extra/opengl/gl/gl-docs.factor b/extra/opengl/gl/gl-docs.factor
index 6efe865ddd..20a87e3efc 100644
--- a/extra/opengl/gl/gl-docs.factor
+++ b/extra/opengl/gl/gl-docs.factor
@@ -3,18 +3,50 @@ USING: help.syntax help.markup ;
IN: opengl.gl
+ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
+
+ { $subsection glVertex2d }
+ { $subsection glVertex2f }
+ { $subsection glVertex2i }
+ { $subsection glVertex2s }
+ { $subsection glVertex3d }
+ { $subsection glVertex3f }
+ { $subsection glVertex3i }
+ { $subsection glVertex3s }
+ { $subsection glVertex4d }
+ { $subsection glVertex4f }
+ { $subsection glVertex4i }
+ { $subsection glVertex4s }
+ { $subsection glVertex2dv }
+ { $subsection glVertex2fv }
+ { $subsection glVertex2iv }
+ { $subsection glVertex2sv }
+ { $subsection glVertex3dv }
+ { $subsection glVertex3fv }
+ { $subsection glVertex3iv }
+ { $subsection glVertex3sv }
+ { $subsection glVertex4dv }
+ { $subsection glVertex4fv }
+ { $subsection glVertex4iv }
+ { $subsection glVertex4sv } ;
+
ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
- { $table { { $link GL_POINTS } "individual points" }
- { { $link GL_LINES } "pairs of vertices interpreted as indivisual line segments" }
- { { $link GL_LINE_STRIP } "series of connected line segments" }
- { { $link GL_LINE_LOOP } "same as above, with a segment added between last and first vertices" }
- { { $link GL_TRIANGLES } "triples of vertices interpreted as triangles" }
- { { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
- { { $link GL_TRIANGLE_FAN } "linked fan of triangles" }
- { { $link GL_QUADS } "quadruples of vertices interpreted as four-sided polygons" }
- { { $link GL_QUAD_STRIP } "linked strip of quadrilaterals" }
- { { $link GL_POLYGON } "boundary of a simple, convex polygon" } }
+ { $table
+ { { $link GL_POINTS } "individual points" }
+ { { $link GL_LINES } "pairs of vertices interpreted as "
+ "indivisual line segments" }
+ { { $link GL_LINE_STRIP } "series of connected line segments" }
+ { { $link GL_LINE_LOOP } "same as above, with a segment added "
+ "between last and first vertices" }
+ { { $link GL_TRIANGLES }
+ "triples of vertices interpreted as triangles" }
+ { { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
+ { { $link GL_TRIANGLE_FAN } "linked fan of triangles" }
+ { { $link GL_QUADS }
+ "quadruples of vertices interpreted as four-sided polygons" }
+ { { $link GL_QUAD_STRIP } "linked strip of quadrilaterals" }
+ { { $link GL_POLYGON } "boundary of a simple, convex polygon" } }
;
From 28023a60ee542d11bc766ac2577babe3311519ea Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 15 Mar 2008 18:02:50 -0600
Subject: [PATCH 030/197] factor.el tweak
---
misc/factor.el | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/misc/factor.el b/misc/factor.el
index 7225ef91fd..5515476c22 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -83,7 +83,9 @@
(" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face)
"MAIN:"
- "IN:" "USING:" "TUPLE:" "^C:" "^M:" "USE:" "REQUIRE:" "PROVIDE:"
+ "IN:" "USING:" "TUPLE:" "^C:" "^M:"
+ "METHOD:"
+ "USE:" "REQUIRE:" "PROVIDE:"
"REQUIRES:"
"GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:"
"C-STRUCT:"
From b36f1e4ea540f467d0526bb621033371a31c9bd9 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 15 Mar 2008 18:03:08 -0600
Subject: [PATCH 031/197] more gl help
---
extra/opengl/gl/gl-docs.factor | 25 ++++++++++++++++++++-----
1 file changed, 20 insertions(+), 5 deletions(-)
diff --git a/extra/opengl/gl/gl-docs.factor b/extra/opengl/gl/gl-docs.factor
index 20a87e3efc..84004cbbdf 100644
--- a/extra/opengl/gl/gl-docs.factor
+++ b/extra/opengl/gl/gl-docs.factor
@@ -3,6 +3,10 @@ USING: help.syntax help.markup ;
IN: opengl.gl
+ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
+ { $subsection "opengl-specifying-vertices" }
+ { $subsection "opengl-geometric-primitives" } ;
+
ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
{ $subsection glVertex2d }
@@ -34,11 +38,11 @@ ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
{ $table
{ { $link GL_POINTS } "individual points" }
- { { $link GL_LINES } "pairs of vertices interpreted as "
- "indivisual line segments" }
+ { { $link GL_LINES } { "pairs of vertices interpreted as "
+ "individual line segments" } }
{ { $link GL_LINE_STRIP } "series of connected line segments" }
- { { $link GL_LINE_LOOP } "same as above, with a segment added "
- "between last and first vertices" }
+ { { $link GL_LINE_LOOP } { "same as above, with a segment added "
+ "between last and first vertices" } }
{ { $link GL_TRIANGLES }
"triples of vertices interpreted as triangles" }
{ { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
@@ -52,4 +56,15 @@ ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
HELP: glBegin
{ $values { "mode"
- { "One of the " { $link "opengl-geometric-primitives" } } } } ;
\ No newline at end of file
+ { "One of the " { $link "opengl-geometric-primitives" } } } } ;
+
+HELP: glPolygonMode
+ { $values { "face" { "One of the following:"
+ { $list { $link GL_FRONT }
+ { $link GL_BACK }
+ { $link GL_FRONT_AND_BACK } } } }
+ { "mode" { "One of the following:"
+ { $list
+ { $link GL_POINT }
+ { $link GL_LINE }
+ { $link GL_FILL } } } } } ;
\ No newline at end of file
From 1e9abc971c2d067178feeaaf7b58a0666f9f9f1b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 15 Mar 2008 19:36:28 -0500
Subject: [PATCH 032/197] move cairo to cairo.ffi add low-level cairo resource
disposal add cairo.png viewer
---
extra/cairo/authors.txt | 1 +
extra/cairo/{cairo.factor => ffi/ffi.factor} | 2 +-
extra/cairo/lib/lib.factor | 40 +++++++++++++++++
extra/cairo/png/png.factor | 45 ++++++++++++++++++++
4 files changed, 87 insertions(+), 1 deletion(-)
rename extra/cairo/{cairo.factor => ffi/ffi.factor} (99%)
create mode 100644 extra/cairo/lib/lib.factor
create mode 100644 extra/cairo/png/png.factor
diff --git a/extra/cairo/authors.txt b/extra/cairo/authors.txt
index 4a2736dd93..68d35d192b 100644
--- a/extra/cairo/authors.txt
+++ b/extra/cairo/authors.txt
@@ -1 +1,2 @@
Sampo Vuori
+Doug Coleman
diff --git a/extra/cairo/cairo.factor b/extra/cairo/ffi/ffi.factor
similarity index 99%
rename from extra/cairo/cairo.factor
rename to extra/cairo/ffi/ffi.factor
index 0d3e0c27e6..d7aa90c464 100644
--- a/extra/cairo/cairo.factor
+++ b/extra/cairo/ffi/ffi.factor
@@ -10,7 +10,7 @@
USING: alien alien.syntax combinators system ;
-IN: cairo
+IN: cairo.ffi
<< "cairo" {
{ [ win32? ] [ "cairo.dll" ] }
diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor
new file mode 100644
index 0000000000..9e226ee47a
--- /dev/null
+++ b/extra/cairo/lib/lib.factor
@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types cairo.ffi continuations destructors
+kernel libc locals math combinators.cleave shuffle new-slots
+accessors ;
+IN: cairo.lib
+
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
+: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
+
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: cairo-surface-t-destroy-always ( alien -- )
+ <cairo-surface-t> add-always-destructor ;
+
+: cairo-surface-t-destroy-later ( alien -- )
+ <cairo-surface-t> add-error-destructor ;
+
+: cairo-surface>array ( surface -- cairo-t byte-array )
+ [
+ dup
+ [ drop CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height ] tri
+ over 4 *
+ 2dup * [
+ malloc dup free-always [
+ 5 -nrot cairo_image_surface_create_for_data
+ dup cairo-surface-t-destroy-always
+ cairo_create dup cairo-t-destroy-later
+ [ swap 0 0 cairo_set_source_surface ] keep
+ dup cairo_paint
+ ] keep
+ ] keep memory>byte-array
+ ] with-destructors ;
diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
new file mode 100644
index 0000000000..b9da14088c
--- /dev/null
+++ b/extra/cairo/png/png.factor
@@ -0,0 +1,45 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.cleave kernel new-slots
+accessors math ui.gadgets ui.render opengl.gl byte-arrays
+namespaces opengl cairo.ffi cairo.lib ;
+IN: cairo.png
+
+TUPLE: png surface width height cairo-t array ;
+TUPLE: png-gadget png ;
+
+: <png> ( path -- png )
+ cairo_image_surface_create_from_png
+ dup [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height ] [ ] tri
+ cairo-surface>array png construct-boa ;
+
+: write-png ( png path -- )
+ >r png-surface r>
+ cairo_surface_write_to_png
+ zero? [ "write png failed" throw ] unless ;
+
+: <png-gadget> ( path -- gadget )
+ png-gadget construct-gadget swap
+ <png> >>png ;
+
+M: png-gadget pref-dim* ( gadget -- )
+ png>>
+ [ width>> ] [ height>> ] bi 2array ;
+
+M: png-gadget draw-gadget* ( gadget -- )
+ origin get [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ png>>
+ [ width>> ]
+ [ height>> GL_RGBA GL_UNSIGNED_BYTE ]
+ [ array>> ] tri
+ glDrawPixels
+ ] with-translation ;
+
+M: png-gadget graft* ( gadget -- )
+ drop ;
+
+M: png-gadget ungraft* ( gadget -- )
+ png>> surface>> cairo_destroy ;
From ed7af26003e9d082c05a457d1d63e90a8dfed1b2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 15 Mar 2008 19:36:40 -0500
Subject: [PATCH 033/197] fix using
---
extra/cairo-demo/cairo-demo.factor | 22 ++++++++++++----------
1 file changed, 12 insertions(+), 10 deletions(-)
diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor
index 316479d53c..ab8858efb3 100644
--- a/extra/cairo-demo/cairo-demo.factor
+++ b/extra/cairo-demo/cairo-demo.factor
@@ -6,7 +6,7 @@
! http://cairographics.org/samples/text/
-USING: cairo math math.constants byte-arrays kernel ui ui.render
+USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
ui.gadgets opengl.gl ;
IN: cairo-demo
@@ -22,14 +22,16 @@ IN: cairo-demo
TUPLE: cairo-gadget image-array cairo-t ;
-M: cairo-gadget draw-gadget* ( gadget -- )
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
- cairo-gadget-image-array glDrawPixels ;
+! M: cairo-gadget draw-gadget* ( gadget -- )
+! 0 0 glRasterPos2i
+! 1.0 -1.0 glPixelZoom
+! >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+! cairo-gadget-image-array glDrawPixels ;
: create-surface ( gadget -- cairo_surface_t )
- make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ;
+ make-image-array
+ [ swap set-cairo-gadget-image-array ] keep
+ convert-array-to-surface ;
: init-cairo ( gadget -- cairo_t )
create-surface cairo_create ;
@@ -56,10 +58,10 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
cairo_fill ;
M: cairo-gadget graft* ( gadget -- )
- dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
+ dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
-M: cairo-gadget ungraft* ( gadget -- )
- cairo-gadget-cairo-t cairo_destroy ;
+! M: cairo-gadget ungraft* ( gadget -- )
+! cairo-gadget-cairo-t cairo_destroy ;
: <cairo-gadget> ( -- gadget )
cairo-gadget construct-gadget ;
From fe9ab0e26ba5a272bf3dbf97aecdcf4e3375eac4 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 15 Mar 2008 17:45:05 -0700
Subject: [PATCH 034/197] COM unit tests. Remove redundant call-with word and
use cleave instead.
---
extra/bunny/outlined/outlined.factor | 6 +-
extra/combinators/lib/lib.factor | 20 ++---
extra/io/windows/files/files.factor | 5 +-
extra/opengl/demo-support/demo-support.factor | 5 +-
extra/opengl/shaders/shaders.factor | 4 +-
extra/windows/com/com-tests.factor | 87 +++++++++++++++++++
extra/windows/com/com.factor | 19 ++--
extra/windows/com/syntax/syntax.factor | 4 -
8 files changed, 117 insertions(+), 33 deletions(-)
create mode 100755 extra/windows/com/com-tests.factor
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index d7064ebdde..67617b0273 100644
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -1,5 +1,5 @@
USING: arrays bunny.model bunny.cel-shaded
-combinators.lib continuations kernel math multiline
+combinators.cleave continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl
opengl.capabilities sequences ui.gadgets ;
IN: bunny.outlined
@@ -177,7 +177,7 @@ TUPLE: bunny-outlined
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
[ f swap set-bunny-outlined-framebuffer-dim ]
- } call-with
+ } cleave
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
@@ -237,4 +237,4 @@ M: bunny-outlined dispose
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
[ dispose-framebuffer ]
- } call-with ;
+ } cleave ;
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 99386272f3..c617466d1b 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -130,24 +130,14 @@ MACRO: parallel-call ( quots -- )
! map-call and friends
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: (make-call-with) ( quots -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
-
-MACRO: call-with ( quots -- )
- (make-call-with) ;
-
MACRO: map-call-with ( quots -- )
- [ (make-call-with) ] keep length [ narray ] curry compose ;
-
-: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
- [ 2drop ] append ;
-
-MACRO: call-with2 ( quots -- )
- (make-call-with2) ;
+ [ [ [ keep ] curry ] map concat [ drop ] append ] keep length [ narray ] curry compose ;
MACRO: map-call-with2 ( quots -- )
- [ (make-call-with2) ] keep length [ narray ] curry append ;
+ [
+ [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+ [ 2drop ] append
+ ] keep length [ narray ] curry append ;
MACRO: map-exec-with ( words -- )
[ 1quotation ] map [ map-call-with ] curry ;
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 3d51e65116..afd2a09e08 100644
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -3,7 +3,8 @@
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
-sequences combinators.lib namespaces words symbols ;
+sequences combinators.lib combinators.cleave
+namespaces words symbols ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
@@ -19,7 +20,7 @@ SYMBOLS: +read-only+ +hidden+ +system+
[
first2 expand-constants
[ swapd mask? [ , ] [ drop ] if ] 2curry
- ] map call-with
+ ] map cleave
] { } make ;
: win32-file-attributes ( n -- seq )
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 59b7a3bcc3..f7df84cbda 100644
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,4 +1,5 @@
-USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
+USING: arrays combinators.lib combinators.cleave kernel math
+ math.functions math.vectors namespaces
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
IN: opengl.demo-support
@@ -49,7 +50,7 @@ M: demo-gadget pref-dim* ( gadget -- dim )
glLoadIdentity
{ [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
- [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ;
+ [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } cleave ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set ;
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index c8186e55c3..7403b7cb05 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien libc opengl math sequences combinators.lib
-macros arrays ;
+combinators.cleave macros arrays ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@@ -118,7 +118,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
: (make-with-gl-program) ( uniforms quot -- q )
[
\ dup ,
- [ swap (with-gl-program-uniforms) , \ call-with , % ]
+ [ swap (with-gl-program-uniforms) , \ cleave , % ]
[ ] make ,
\ (with-gl-program) ,
] [ ] make ;
diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor
new file mode 100755
index 0000000000..2e6e8a9c22
--- /dev/null
+++ b/extra/windows/com/com-tests.factor
@@ -0,0 +1,87 @@
+USING: kernel windows.com windows.com.syntax windows.ole32
+alien alien.syntax tools.test libc ;
+IN: windows.com.tests
+
+! Create some test COM interfaces
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+ HRESULT returnOK ( )
+ HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+ int getX ( ) ;
+ void setX ( int newX ) ;
+
+! Implement the IInherited interface in factor using alien-callbacks
+
+: QueryInterface-callback
+ "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 -rot set-void*-nth ]
+ alien-callback ;
+: AddRef-callback
+ "ULONG" { "void*" } "stdcall" [ drop 2 ]
+ alien-callback ;
+: Release-callback
+ "ULONG" { "void*" } "stdcall" [ drop 1 ]
+ alien-callback ;
+: returnOK-callback
+ "HRESULT"{ "void*" } "stdcall" [ drop S_OK ]
+ alien-callback ;
+: returnError-callback
+ "HRESULT"{ "void*" } "stdcall" [ drop E_FAIL ]
+ alien-callback ;
+: getX-callback
+ "int" { "void*" } "stdcall" [ test-interface-x ]
+ alien-callback ;
+: setX-callback
+ "void" { "void*" "int" } "stdcall" [ swap set-test-interface-x ]
+ alien-callback ;
+
+SYMBOL: +test-implementation-vtbl+
+{
+ QueryInterface-callback
+ AddRef-callback
+ Release-callback
+ returnOK-callback
+ returnError-callback
+ getX-callback
+ setX-callback
+} [ execute ] map >c-void*-array
++test-implementation-vtbl+ set
+
+C-STRUCT: test-implementation
+ { "void*" "vtbl" }
+ { "int" "x" } ;
+
+: (make-test-implementation) ( x imp -- imp )
+ [ set-test-implementation-x ] keep
+ +test-implementation-vtbl+ get over set-test-implementation-vtbl ;
+
+: <test-implementation> ( x -- imp )
+ "test-implementation" <c-object> (make-test-implementation) ;
+
+! Test that the words defined by COM-INTERFACE: do their magic
+
+"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
+"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
+"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
+S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
+E_FAIL 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
+1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
+
+! Test that the helper functions for QueryInterface, AddRef, Release work
+
+: <malloced-test-implementation> ( x -- imp )
+ "test-implementation" heap-size malloc (make-test-implementation) ;
+
+SYMBOL: +guinea-pig-implementation+
+
+0 <malloced-test-implementation> +guinea-pig-implementation+ set
+[
+ +guinea-pig-implementation+ get 1array [
+ +guinea-pig-implementation+ get IUnknown-iid com-query-interface
+ ] unit-test
+
+ { } [ +guinea-pig-implementation+ get com-add-ref ] unit-test
+ { } [ +guinea-pig-implementation+ get com-release ] unit-test
+] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
index 9543ec7e6a..477eaad038 100755
--- a/extra/windows/com/com.factor
+++ b/extra/windows/com/com.factor
@@ -1,8 +1,17 @@
USING: alien alien.c-types windows.com.syntax windows.ole32
-windows.types ;
+windows.types continuations ;
IN: windows.com
-COM-INTERFACE: IUnknown f
- HRESULT QueryInterface ( void* this, REFGUID iid, void** ppvObject )
- ULONG AddRef ( void* this )
- ULONG Release ( void* this ) ;
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+ HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+ ULONG AddRef ( )
+ ULONG Release ( ) ;
+
+: com-query-interface ( interface iid -- interface' )
+ f <void*> [ IUnknown::QueryInterface ] keep *void* ;
+
+: com-add-ref ( interface -- )
+ IUnknown::AddRef drop ; inline
+
+: com-release ( interface -- )
+ IUnknown::Release drop ; inline
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 12258644ae..0895c0e201 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -11,10 +11,6 @@ IN: windows.com.syntax
swap vtbl swap void*-nth
] 4 ndip alien-indirect ;
-: parse-inheritance
- scan dup {
- } case ;
-
PRIVATE>
: COM-INTERFACE:
From 382868b3623d7da5508d3e04021abdfe496f6773 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 15 Mar 2008 23:21:53 -0500
Subject: [PATCH 035/197] add a test to make sure assigned ids can't be
inserted twice fix a bug with sqlite finalizers
---
extra/db/sqlite/lib/lib.factor | 4 +++-
extra/db/sqlite/sqlite.factor | 3 ++-
extra/db/tuples/tuples-tests.factor | 13 +++++++++++--
3 files changed, 16 insertions(+), 4 deletions(-)
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index d630522eb8..ec07adca25 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -106,6 +106,8 @@ IN: db.sqlite.lib
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
: sqlite-column-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep
@@ -140,7 +142,7 @@ IN: db.sqlite.lib
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
-: sqlite-step-has-more-rows? ( step-result -- bool )
+: sqlite-step-has-more-rows? ( prepared -- bool )
dup SQLITE_ROW = [
drop t
] [
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 3466301390..b8ef5c7b17 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -38,7 +38,8 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
- statement-handle sqlite-finalize ;
+ statement-handle
+ [ sqlite3_reset drop ] keep sqlite-finalize ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index ba6441bc53..8e347490e4 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -193,8 +193,17 @@ TUPLE: annotation n paste-id summary author mode contents ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
-! [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-tuples ] test-postgresql
+: test-repeated-insert
+ [ ] [ person ensure-table ] unit-test
+
+ [ ] [ person1 get insert-tuple ] unit-test
+ [ person1 get insert-tuple ] must-fail ;
+
+[ native-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-tuples ] test-postgresql
+
+[ assigned-person-schema test-repeated-insert ] test-sqlite
+[ assigned-person-schema test-repeated-insert ] test-postgresql
TUPLE: serialize-me id data ;
From 20ed8ab9a2074caf486ee0f9ee4c2069041ff599 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 00:17:05 -0500
Subject: [PATCH 036/197] Fix code heap compaction bug
---
vm/code_gc.c | 2 ++
vm/data_gc.h | 9 +++++++--
2 files changed, 9 insertions(+), 2 deletions(-)
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 5c51fe7e8b..5b0d2ebabb 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -375,6 +375,8 @@ void forward_object_xts(void)
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
+ if(word->profiling)
+ word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
diff --git a/vm/data_gc.h b/vm/data_gc.h
index d9c3d8eb1c..8f93ce79a1 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -263,13 +263,18 @@ DEFPUSHPOP(root_,extra_roots)
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
+INLINE bool in_data_heap_p(CELL ptr)
+{
+ return (ptr >= data_heap->segment->start
+ && ptr <= data_heap->segment->end);
+}
+
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
- if((CELL)ptr > data_heap->segment->start
- && (CELL)ptr < data_heap->segment->end)
+ if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
From ae480fb329f686e16642cfcc03384fa3ba6c7cc3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 00:17:32 -0500
Subject: [PATCH 037/197] SetWindowPos
---
extra/windows/user32/user32.factor | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor
index 39879bf91d..e3e8a23ca7 100755
--- a/extra/windows/user32/user32.factor
+++ b/extra/windows/user32/user32.factor
@@ -1283,7 +1283,13 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
! FUNCTION: SetWindowLongA
! FUNCTION: SetWindowLongW
! FUNCTION: SetWindowPlacement
-! FUNCTION: SetWindowPos
+FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
+
+: HWND_BOTTOM ALIEN: 1 ;
+: HWND_NOTOPMOST ALIEN: -2 ;
+: HWND_TOP ALIEN: 0 ;
+: HWND_TOPMOST ALIEN: -1 ;
+
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA
! FUNCTION: SetWindowsHookExA
From d0687751ed4fa9838ecfd509d3327560ba787213 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 00:18:05 -0500
Subject: [PATCH 038/197] Fix Windows UI memory corruption
---
extra/ui/windows/windows.factor | 27 +++++++++++++++++++++------
1 file changed, 21 insertions(+), 6 deletions(-)
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 8eb5fe59aa..0c9c23cf76 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -376,6 +376,22 @@ SYMBOL: trace-messages?
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+! ! ! !
+: set-world-dim ( dim world -- )
+ swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
+ SetWindowPos drop ;
+USE: random
+USE: arrays
+
+: twiddle
+ 100 500 random +
+ 100 500 random +
+ 2array
+ "x" get-global find-world
+ set-world-dim
+ yield ;
+! ! ! !
+
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
@@ -436,17 +452,16 @@ SYMBOL: trace-messages?
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
- "MSG" <c-object> msg-obj set-global
+ "MSG" malloc-object msg-obj set-global
"Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
- class-name-ptr get-global [
- dup f UnregisterClass drop
- free
- ] when*
- f class-name-ptr set-global ;
+ class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+ msg-obj get-global [ free ] when*
+ f class-name-ptr set-global
+ f msg-obj set-global ;
: setup-pixel-format ( hdc -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
From 194b0d827efa8e2dc7e35c2beb42d1f77b8ebea8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 00:18:28 -0500
Subject: [PATCH 039/197] Clarify docs for constructors
---
core/tuples/tuples-docs.factor | 20 ++++++++++++++++++--
1 file changed, 18 insertions(+), 2 deletions(-)
diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor
index c03b9784ee..3af7d27d86 100755
--- a/core/tuples/tuples-docs.factor
+++ b/core/tuples/tuples-docs.factor
@@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
$nl
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
+"Examples of constructors:"
+{ $code
+ "TUPLE: color red green blue alpha ;"
+ ""
+ "C: <rgba> rgba"
+ ": <rgba> color construct-boa ; ! identical to above"
+ ""
+ ": <rgb>"
+ " { set-color-red set-color-green set-color-blue }"
+ " color construct ;"
+ ": <rgb> f <rgba> ; ! identical to above"
+ ""
+ ": <color> construct-empty ;"
+ ": <color> { } color construct ; ! identical to above"
+ ": <color> f f f f <rgba> ; ! identical to above"
+}
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
ARTICLE: "tuple-delegation" "Delegation"
@@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"An example:"
-{ $code "TUPLE: person name address phone ;" }
-"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
+{ $code "TUPLE: person name address phone ;" "C: <person> person" }
+"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
{ $table
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }
From 91f4dadea80b2cce376d68c0630d96498e916b61 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 00:19:04 -0500
Subject: [PATCH 040/197] Fix openssl binding on Windows
---
extra/openssl/libcrypto/libcrypto.factor | 2 +-
extra/openssl/libssl/libssl.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
mode change 100644 => 100755 extra/openssl/libssl/libssl.factor
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index bc65f72435..d06afdc5ea 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -11,7 +11,7 @@ IN: openssl.libcrypto
<<
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "stdcall" ] }
+ { [ win32? ] [ "libeay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
old mode 100644
new mode 100755
index d8709cbf53..11dcee31f6
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
- { [ win32? ] [ "ssleay32.dll" "stdcall" ] }
+ { [ win32? ] [ "ssleay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
From 8b956d1efa50f8df464c864d30f540adad489d14 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@goo.local>
Date: Sun, 16 Mar 2008 02:21:51 -0500
Subject: [PATCH 041/197] Fixing deployment
---
core/alien/c-types/c-types.factor | 4 ++--
core/io/files/files.factor | 5 +----
core/io/io.factor | 8 +++++---
extra/bootstrap/tools/tools.factor | 1 +
extra/io/unix/unix.factor | 2 --
extra/io/windows/nt/nt.factor | 2 --
extra/tools/deploy/shaker/shaker.factor | 7 ++++---
extra/ui/freetype/freetype.factor | 5 +----
8 files changed, 14 insertions(+), 20 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index c3f5c64b29..f1d8abdc1e 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
r> add*
] when ;
-: malloc-file-contents ( path -- alien )
- binary file-contents malloc-byte-array ;
+: malloc-file-contents ( path -- alien len )
+ binary file-contents dup malloc-byte-array swap length ;
[
[ alien-cell ]
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 18cdbd3791..5de86d0baa 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -222,10 +222,7 @@ M: pathname <=> [ pathname-string ] compare ;
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
- dupd [ file-info file-info-size read ] with-file-reader ;
-
-! : file-contents ( path encoding -- str )
-! dupd [ file-length read ] with-file-reader ;
+ <file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
diff --git a/core/io/io.factor b/core/io/io.factor
index 2d927d088a..ef9eae7902 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables generic kernel math namespaces sequences strings
- continuations assocs io.styles sbufs ;
+USING: hashtables generic kernel math namespaces sequences
+continuations assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str )
@@ -88,4 +88,6 @@ SYMBOL: stderr
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
: contents ( stream -- str )
- 2048 <sbuf> [ stream-copy ] keep >string ;
+ [
+ [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+ ] with-stream ;
diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor
index 0bf7a032ee..670bca4903 100755
--- a/extra/bootstrap/tools/tools.factor
+++ b/extra/bootstrap/tools/tools.factor
@@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
+ "tools.vocabs.monitor"
"editors"
} [ require ] each
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 01e29866eb..1f0492a060 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -3,5 +3,3 @@ io.unix.launcher io.unix.mmap io.backend
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
-
-"tools.vocabs.monitor" require
diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor
index 319acc35f8..1baec5658f 100755
--- a/extra/io/windows/nt/nt.factor
+++ b/extra/io/windows/nt/nt.factor
@@ -13,5 +13,3 @@ USE: io.windows.files
USE: io.backend
T{ windows-nt-io } set-io-backend
-
-"tools.vocabs.monitor" require
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index edf78de479..44fb15ac7e 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -133,9 +133,10 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when
[
- io.backend:io-backend
+ io.backend:io-backend ,
"default-buffer-size" "io.nonblocking" lookup ,
- ] { "alarms" "io" "tools" } strip-vocab-globals %
+ ] { } make
+ { "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
@@ -193,7 +194,7 @@ IN: tools.deploy.shaker
global swap
'[ drop , member? not ] assoc-subset
[ drop string? not ] assoc-subset ! strip CLI args
- dup keys .
+ dup keys unparse show
21 setenv
] [ drop ] if ;
diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor
index 8dca72c29e..e9527e6f9a 100755
--- a/extra/ui/freetype/freetype.factor
+++ b/extra/ui/freetype/freetype.factor
@@ -73,10 +73,7 @@ M: freetype-renderer free-fonts ( world -- )
] keep *void* ;
: open-face ( font style -- face )
- ttf-name ttf-path
- dup malloc-file-contents
- swap file-info file-info-size
- (open-face) ;
+ ttf-name ttf-path malloc-file-contents (open-face) ;
SYMBOL: dpi
From ec698b7f53fbd5af40a5eef170eb0dc93e243e5d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:43:00 -0500
Subject: [PATCH 042/197] Parser overhaul
---
core/debugger/debugger.factor | 2 +-
core/generic/generic-docs.factor | 13 ++---
core/generic/generic.factor | 54 +++++++------------
core/generic/math/math.factor | 2 +-
core/generic/standard/standard.factor | 4 --
.../specializers/specializers.factor | 36 ++++++++++---
core/parser/parser.factor | 20 +++++--
core/slots/slots.factor | 3 +-
core/syntax/syntax.factor | 19 +++----
core/words/words.factor | 2 +-
extra/delegate/delegate.factor | 2 +-
extra/locals/locals-tests.factor | 19 ++++++-
extra/locals/locals.factor | 20 ++-----
extra/memoize/memoize.factor | 2 +-
extra/multiline/multiline.factor | 2 +-
extra/promises/promises.factor | 2 +-
extra/unicode/data/data.factor | 2 +-
17 files changed, 111 insertions(+), 93 deletions(-)
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 40bcbe78b1..ad2fa14954 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -214,7 +214,7 @@ M: check-closed summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
- drop "Invalid parameters for define-method" ;
+ drop "Invalid parameters for create-method" ;
M: check-tuple summary
drop "Invalid class for define-constructor" ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 9b799d9143..62b85dde3a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -34,7 +34,7 @@ $nl
{ $subsection define-generic }
{ $subsection define-simple-generic }
"Methods can be added to existing generic words:"
-{ $subsection define-method }
+{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
@@ -123,7 +123,7 @@ HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
-{ method define-method POSTPONE: M: } related-words
+{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@@ -140,16 +140,17 @@ HELP: order
HELP: check-method
{ $values { "class" class } { "generic" generic } }
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
-{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
+{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
-HELP: define-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+HELP: create-method
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
+{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
+{ $notes "To define a method, pass the output value to " { $link define } "." } ;
HELP: implementors
{ $values { "class" class } { "seq" "a sequence of generic words" } }
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 3c83b87d49..ad31831e94 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -17,10 +17,6 @@ M: object perform-combination
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
-GENERIC: method-prologue ( class combination -- quot )
-
-M: object method-prologue 2drop [ ] ;
-
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
@@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
\ check-method construct-boa throw
- ] unless ;
+ ] unless ; inline
-: with-methods ( word quot -- )
+: with-methods ( generic quot -- )
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
-: make-method-def ( quot class generic -- quot )
- "combination" word-prop method-prologue swap append ;
-
-PREDICATE: word method-body "method-def" word-prop >boolean ;
+PREDICATE: word method-body
+ "method-generic" word-prop >boolean ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
-: method-word-props ( quot class generic -- assoc )
+: method-word-props ( class generic -- assoc )
[
"method-generic" set
"method-class" set
- "method-def" set
] H{ } make-assoc ;
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
check-method
- [ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
- tuck set-word-props
- dup rot define ;
+ [ set-word-props ] keep ;
-: redefine-method ( quot class generic -- )
- [ method swap "method-def" set-word-prop ] 3keep
- [ make-method-def ] 2keep
- method swap define ;
+: reveal-method ( method class generic -- )
+ [ set-at ] with-methods ;
-: define-method ( quot class generic -- )
- >r bootstrap-word r>
- 2dup method [
- redefine-method
+: create-method ( class generic -- method )
+ 2dup method dup [
+ 2nip
] [
- [ <method> ] 2keep
- [ set-at ] with-methods
+ drop [ <method> dup ] 2keep reveal-method
] if ;
+: <default-method> ( generic combination -- method )
+ object bootstrap-word pick <method>
+ [ -rot make-default-method define ] keep ;
+
: define-default-method ( generic combination -- )
- dupd make-default-method object bootstrap-word pick <method>
- "default-method" set-word-prop ;
+ dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
M: method-spec where
@@ -108,11 +98,10 @@ M: method-spec set-where
first2 method set-where ;
M: method-spec definer
- drop \ M: \ ; ;
+ first2 method definer ;
M: method-spec definition
- first2 method dup
- [ "method-def" word-prop ] when ;
+ first2 method definition ;
: forget-method ( class generic -- )
check-method
@@ -125,9 +114,6 @@ M: method-spec forget*
M: method-body definer
drop \ M: \ ; ;
-M: method-body definition
- "method-def" word-prop ;
-
M: method-body forget*
dup "method-class" word-prop
swap "method-generic" word-prop
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 27b0ddb7a2..9fd5481a39 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over method
- [ word-def ]
+ [ 1quotation ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 313f487c99..c634e02e75 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -8,10 +8,6 @@ IN: generic.standard
TUPLE: standard-combination # ;
-M: standard-combination method-prologue
- standard-combination-# object
- <array> swap add* [ declare ] curry ;
-
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 10a9fda3ea..5153d84c7f 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -24,20 +24,40 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
-: specializer-methods ( quot word -- default alist )
+: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc ;
+: method-declaration ( method -- quot )
+ dup "method-generic" word-prop dispatch# object <array>
+ swap "method-class" word-prop add* ;
+
+: specialize-method ( quot method -- quot' )
+ method-declaration [ declare ] curry swap append ;
+
+: specialize-quot ( quot specializer -- quot' )
+ dup { number } = [
+ drop tag-specializer
+ ] [
+ specializer-cases alist>quot
+ ] if ;
+
+: standard-method? ( method -- ? )
+ dup method-body? [
+ "method-generic" word-prop standard-generic?
+ ] [ drop f ] if ;
+
: specialized-def ( word -- quot )
- dup word-def swap "specializer" word-prop [
- dup { number } = [
- drop tag-specializer
- ] [
- specializer-methods alist>quot
- ] if
- ] when* ;
+ dup word-def swap {
+ { [ dup standard-method? ] [ specialize-method ] }
+ {
+ [ dup "specializer" word-prop ]
+ [ "specializer" word-prop specialize-quot ]
+ }
+ { [ t ] [ drop ] }
+ } cond ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 50f8f582d3..c955817ab9 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -215,9 +215,6 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-: create-in ( string -- word )
- in get create dup set-word dup save-location ;
-
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
@@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
: parse-tokens ( end -- seq )
100 <vector> swap (parse-tokens) >array ;
+: create-in ( string -- word )
+ in get create dup set-word dup save-location ;
+
: CREATE ( -- word ) scan create-in ;
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
+
: create-class-in ( word -- word )
in get create
dup save-class-location
@@ -284,6 +288,12 @@ M: no-word summary
] ?if
] when ;
+: create-method-in ( class generic -- method )
+ create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-word create-method-in ;
+
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
@@ -355,7 +365,9 @@ TUPLE: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) CREATE dup reset-generic parse-definition ;
+: (:) CREATE-WORD parse-definition ;
+
+: (M:) CREATE-METHOD parse-definition ;
GENERIC: expected>string ( obj -- str )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 92d22247bd..7e9046573f 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
- over define-simple-generic -rot define-method ;
+ over define-simple-generic
+ >r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 79a5553228..d9870b08da 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -97,7 +97,7 @@ IN: bootstrap.syntax
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"SYMBOL:" [
- CREATE dup reset-generic define-symbol
+ CREATE-WORD define-symbol
] define-syntax
"DEFER:" [
@@ -111,31 +111,26 @@ IN: bootstrap.syntax
] define-syntax
"GENERIC:" [
- CREATE dup reset-word
- define-simple-generic
+ CREATE-GENERIC define-simple-generic
] define-syntax
"GENERIC#" [
- CREATE dup reset-word
+ CREATE-GENERIC
scan-word <standard-combination> define-generic
] define-syntax
"MATH:" [
- CREATE dup reset-word
+ CREATE-GENERIC
T{ math-combination } define-generic
] define-syntax
"HOOK:" [
- CREATE dup reset-word scan-word
+ CREATE-GENERIC scan-word
<hook-combination> define-generic
] define-syntax
"M:" [
- f set-word
- location >r
- scan-word bootstrap-word scan-word
- [ parse-definition -rot define-method ] 2keep
- 2array r> remember-definition
+ (M:) define
] define-syntax
"UNION:" [
@@ -163,7 +158,7 @@ IN: bootstrap.syntax
] define-syntax
"C:" [
- CREATE dup reset-generic
+ CREATE-WORD
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax
diff --git a/core/words/words.factor b/core/words/words.factor
index ce69c1ff2e..73b877fdbb 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method-def" word-prop ] [ t ] }
+ { [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 654d096b26..9eabfae95c 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -7,7 +7,7 @@ IN: delegate
swap { } like "protocol-words" set-word-prop ;
: PROTOCOL:
- CREATE dup reset-generic dup define-symbol
+ CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index b4f1b0a61e..bd1e62f22a 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -1,5 +1,6 @@
USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays strings prettyprint ;
+namespaces arrays strings prettyprint io.streams.string parser
+;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ "[| a! | ]" ] [
[| a! | ] unparse
] unit-test
+
+DEFER: xyzzy
+
+[ ] [
+ "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 10 ] [ 10 xyzzy ] unit-test
+
+[ ] [
+ "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 5 ] [ 10 xyzzy ] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 9819e65e37..a8f5e139e7 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -249,13 +249,14 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals ;
-: ((::)) ( word -- word quot )
+: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
-: (::) ( -- word quot )
- CREATE dup reset-generic ((::)) ;
+: (::) CREATE-WORD parse-locals-definition ;
+
+: (M::) CREATE-METHOD parse-locals-definition ;
PRIVATE>
@@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
: :: (::) define ; parsing
-! This will be cleaned up when method tuples and method words
-! are unified
-: create-method ( class generic -- method )
- 2dup method dup
- [ 2nip ]
- [ drop 2dup [ ] -rot define-method create-method ] if ;
-
-: CREATE-METHOD ( -- class generic body )
- scan-word bootstrap-word scan-word 2dup
- create-method f set-word dup save-location ;
-
-: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
+: M:: (M::) define ; parsing
: MACRO:: (::) define-macro ; parsing
diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor
index 3b0b8fd29f..ab915ae7d5 100755
--- a/extra/memoize/memoize.factor
+++ b/extra/memoize/memoize.factor
@@ -40,7 +40,7 @@ IN: memoize
over make-memoizer define ;
: MEMO:
- CREATE dup reset-generic parse-definition define-memoized ; parsing
+ CREATE-WORD parse-definition define-memoized ; parsing
PREDICATE: word memoized "memoize" word-prop ;
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index 5baa205d15..079f484274 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -18,7 +18,7 @@ IN: multiline
lexer get next-line ;
: STRING:
- CREATE dup reset-generic
+ CREATE-WORD
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor
index 3724b929f0..469f6a91ed 100755
--- a/extra/promises/promises.factor
+++ b/extra/promises/promises.factor
@@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ;
] [ ] make ;
: LAZY:
- CREATE dup reset-generic
+ CREATE-WORD
dup parse-definition
make-lazy-quot define ; parsing
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 11be803893..d8e1e8937a 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -5,7 +5,7 @@ IN: unicode.data
<<
: VALUE:
- CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
+ CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;
From bc71849bf665e071a291bfdfbdee9ca031193b86 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:44:17 -0500
Subject: [PATCH 043/197] Fix bogus f variable in global namespace
---
core/threads/threads-tests.factor | 2 ++
core/threads/threads.factor | 2 --
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index c2e627e7bf..d746404cba 100755
--- a/core/threads/threads-tests.factor
+++ b/core/threads/threads-tests.factor
@@ -14,3 +14,5 @@ yield
[ 3 ] [
[ 3 swap resume-with ] "Test suspend" suspend
] unit-test
+
+[ f ] [ f get-global ] unit-test
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index b4fd6eee60..d7d7988893 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
: threads 41 getenv ;
-threads global [ H{ } assoc-like ] change-at
-
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )
From d06db3f628693ad5d40933cb6ca8b8bf056ba24d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:44:39 -0500
Subject: [PATCH 044/197] Fix bootstrap error exit code
---
core/bootstrap/stage1.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 0e038d0a10..74b4d03cbb 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
+ 1 exit
] recover
] [
"Cannot find " write write "." print
From 7d3c590cfe1a35437d8236629d46bce154f3b24a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:45:45 -0500
Subject: [PATCH 045/197] Update logging for parser change
---
extra/logging/logging.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index 5846515dca..42545500a5 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -127,8 +127,7 @@ PRIVATE>
: LOG:
#! Syntax: name level
- CREATE
- dup reset-generic
+ CREATE-WORD
dup scan-word
[ >r >r 1array stack>message r> r> log-message ] 2curry
define ; parsing
From 254d8455a3875d80e4d9328b98292a5892c32361 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@goo.local>
Date: Sun, 16 Mar 2008 03:43:24 -0500
Subject: [PATCH 046/197] load-library returns f if library not defined
---
core/alien/alien-docs.factor | 3 +--
core/alien/alien.factor | 2 +-
2 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 475cf72d28..95b29ee50b 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
-{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
+{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 0369d55fb3..bce2e16d73 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -57,7 +57,7 @@ TUPLE: library path abi dll ;
over dup [ dlopen ] when \ library construct-boa ;
: load-library ( name -- dll )
- library library-dll ;
+ library dup [ library-dll ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
From 4a4eb8b7bb59f9528ebed001c2cdd136680361f6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@goo.local>
Date: Sun, 16 Mar 2008 03:43:30 -0500
Subject: [PATCH 047/197] Fix :help
---
extra/help/help-tests.factor | 5 +++++
extra/help/help.factor | 2 +-
2 files changed, 6 insertions(+), 1 deletion(-)
create mode 100644 extra/help/help-tests.factor
diff --git a/extra/help/help-tests.factor b/extra/help/help-tests.factor
new file mode 100644
index 0000000000..e38f2fc15d
--- /dev/null
+++ b/extra/help/help-tests.factor
@@ -0,0 +1,5 @@
+IN: help.tests
+USING: tools.test help kernel ;
+
+[ 3 throw ] must-fail
+[ ] [ :help ] unit-test
diff --git a/extra/help/help.factor b/extra/help/help.factor
index 85f5a35a5c..34e90b2ccf 100755
--- a/extra/help/help.factor
+++ b/extra/help/help.factor
@@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print
- ":vars - list all variables at error time";
+ ":vars - list all variables at error time" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] subset
From 8a8a94206d62abdf8f36ff2c26384ed39c65e646 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 03:51:43 -0500
Subject: [PATCH 048/197] Update unit tests
---
core/definitions/definitions-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index 4e8fb255dd..ebbce4d7e2 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -1,10 +1,10 @@
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
-compiler.units ;
+compiler.units words ;
TUPLE: combination-1 ;
-M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
+M: combination-1 perform-combination 2drop [ ] ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
@@ -13,7 +13,7 @@ SYMBOL: generic-1
[
generic-1 T{ combination-1 } define-generic
- [ ] object \ generic-1 define-method
+ object \ generic-1 create-method [ ] define
] with-compilation-unit
[ ] [
From 67c9e2f63192b8145a703bdf6d6dcc2d2e1079dd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 16 Mar 2008 15:17:11 -0500
Subject: [PATCH 049/197] make openbsd64 bootstrap fix target for openbsd64
---
misc/target | 6 ++++++
vm/os-openbsd-x86.64.h | 7 +++++--
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/misc/target b/misc/target
index 0be7781301..c9f927a507 100755
--- a/misc/target
+++ b/misc/target
@@ -3,9 +3,15 @@
if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
then
echo freebsd-x86-32
+elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ]
+then
+ echo freebsd-x86-64
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ]
then
echo openbsd-x86-32
+elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ]
+then
+ echo openbsd-x86-64
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
then
echo macosx-ppc
diff --git a/vm/os-openbsd-x86.64.h b/vm/os-openbsd-x86.64.h
index ff225c3cd6..3386e80a4b 100644
--- a/vm/os-openbsd-x86.64.h
+++ b/vm/os-openbsd-x86.64.h
@@ -1,7 +1,10 @@
+#include <amd64/signal.h>
+
INLINE void *openbsd_stack_pointer(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->sc_rsp;
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_rsp;
}
#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
From 6a8886b876246132db5723da955b56b57aeab059 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 16 Mar 2008 15:41:52 -0500
Subject: [PATCH 050/197] fix openbsd stat structure
---
extra/unix/stat/openbsd/32/32.factor | 2 +-
extra/unix/stat/openbsd/64/64.factor | 8 ++++----
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor
index 521735c9b4..61a37ba567 100644
--- a/extra/unix/stat/openbsd/32/32.factor
+++ b/extra/unix/stat/openbsd/32/32.factor
@@ -21,7 +21,7 @@ C-STRUCT: stat
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
- { "timespec*" "st_birthtimespec" }
+ { "timespec*" "st_birthtim" }
{ "int64_t" "st_qspare1" }
{ "int64_t" "st_qspare2" } ;
diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor
index 752574a43a..61a37ba567 100644
--- a/extra/unix/stat/openbsd/64/64.factor
+++ b/extra/unix/stat/openbsd/64/64.factor
@@ -12,16 +12,16 @@ C-STRUCT: stat
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
- { "timespec*" "st_atimespec" }
- { "timespec*" "st_mtimespec" }
- { "timespec*" "st_ctimespec" }
+ { "timespec*" "st_atim" }
+ { "timespec*" "st_mtim" }
+ { "timespec*" "st_ctim" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
- { "timespec*" "st_birthtimespec" }
+ { "timespec*" "st_birthtim" }
{ "int64_t" "st_qspare1" }
{ "int64_t" "st_qspare2" } ;
From 906734e8eb0b155bdd5a8a74af8e3749e81f7761 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 16 Mar 2008 16:29:49 -0500
Subject: [PATCH 051/197] add unix types
---
misc/grovel.c | 1 +
1 file changed, 1 insertion(+)
diff --git a/misc/grovel.c b/misc/grovel.c
index 4460c3aab3..1ac23a9631 100644
--- a/misc/grovel.c
+++ b/misc/grovel.c
@@ -133,6 +133,7 @@ int main() {
#endif
#ifdef UNIX
+ unix_types();
#endif
return 0;
From 5bd82ef42b1320001f18eab0f465c4dc5bd2f9e6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 16 Mar 2008 16:40:58 -0500
Subject: [PATCH 052/197] add long
---
misc/grovel.c | 1 +
1 file changed, 1 insertion(+)
diff --git a/misc/grovel.c b/misc/grovel.c
index 1ac23a9631..2e39d2495e 100644
--- a/misc/grovel.c
+++ b/misc/grovel.c
@@ -136,5 +136,6 @@ int main() {
unix_types();
#endif
+ grovel(long);
return 0;
}
From 2cdc172f04eed9b5f4374033fa460fb98e30b737 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 16 Mar 2008 16:41:58 -0500
Subject: [PATCH 053/197] split types on openbsd
---
extra/unix/types/openbsd/32/32.factor | 29 +++++++++++++++++++++
extra/unix/types/openbsd/64/64.factor | 29 +++++++++++++++++++++
extra/unix/types/openbsd/openbsd.factor | 34 +++++--------------------
3 files changed, 64 insertions(+), 28 deletions(-)
create mode 100755 extra/unix/types/openbsd/32/32.factor
create mode 100755 extra/unix/types/openbsd/64/64.factor
mode change 100755 => 100644 extra/unix/types/openbsd/openbsd.factor
diff --git a/extra/unix/types/openbsd/32/32.factor b/extra/unix/types/openbsd/32/32.factor
new file mode 100755
index 0000000000..221f9896b0
--- /dev/null
+++ b/extra/unix/types/openbsd/32/32.factor
@@ -0,0 +1,29 @@
+USING: alien.syntax ;
+IN: unix.types
+
+! OpenBSD 4.2
+
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: int u_int32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint16_t mode_t
+TYPEDEF: __uint16_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
diff --git a/extra/unix/types/openbsd/64/64.factor b/extra/unix/types/openbsd/64/64.factor
new file mode 100755
index 0000000000..b24cc94a90
--- /dev/null
+++ b/extra/unix/types/openbsd/64/64.factor
@@ -0,0 +1,29 @@
+USING: alien.syntax ;
+IN: unix.types
+
+! OpenBSD 4.2
+
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: int u_int32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint32_t mode_t
+TYPEDEF: __uint32_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __uint64_t off_t
+TYPEDEF: __uint64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor
old mode 100755
new mode 100644
index 221f9896b0..9d2508e91c
--- a/extra/unix/types/openbsd/openbsd.factor
+++ b/extra/unix/types/openbsd/openbsd.factor
@@ -1,29 +1,7 @@
-USING: alien.syntax ;
-IN: unix.types
+USING: layouts combinators vocabs.loader ;
+IN: unix.stat
-! OpenBSD 4.2
-
-TYPEDEF: ushort __uint16_t
-TYPEDEF: uint __uint32_t
-TYPEDEF: int __int32_t
-TYPEDEF: longlong __int64_t
-
-TYPEDEF: int int32_t
-TYPEDEF: int u_int32_t
-TYPEDEF: longlong int64_t
-TYPEDEF: ulonglong u_int64_t
-
-TYPEDEF: __uint32_t __dev_t
-TYPEDEF: __uint32_t dev_t
-TYPEDEF: __uint32_t ino_t
-TYPEDEF: __uint16_t mode_t
-TYPEDEF: __uint16_t nlink_t
-TYPEDEF: __uint32_t uid_t
-TYPEDEF: __uint32_t gid_t
-TYPEDEF: __int64_t off_t
-TYPEDEF: __int64_t blkcnt_t
-TYPEDEF: __uint32_t blksize_t
-TYPEDEF: __uint32_t fflags_t
-TYPEDEF: int ssize_t
-TYPEDEF: int pid_t
-TYPEDEF: int time_t
+cell-bits {
+ { 32 [ "unix.types.openbsd.32" require ] }
+ { 64 [ "unix.types.openbsd.64" require ] }
+} case
From d46de0ae592b4edae72f819cce08522b58d11f66 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 16 Mar 2008 15:57:22 -0600
Subject: [PATCH 054/197] io.files: remove old code
---
core/io/files/files.factor | 6 ------
extra/builder/benchmark/benchmark.factor | 10 ++++++----
2 files changed, 6 insertions(+), 10 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 18cdbd3791..e5c6ca9ce5 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -86,16 +86,10 @@ SYMBOL: +unknown+
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
-! : file-length ( path -- n ) stat drop 2nip ;
-
: file-modified ( path -- n ) stat >r 3drop r> ;
-! : file-permissions ( path -- perm ) stat 2drop nip ;
-
: exists? ( path -- ? ) file-modified >boolean ;
-! : directory? ( path -- ? ) stat 3drop ;
-
: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
! Current working directory
diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor
index 444e5b6ea7..2f38462976 100644
--- a/extra/builder/benchmark/benchmark.factor
+++ b/extra/builder/benchmark/benchmark.factor
@@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
IN: builder.benchmark
-: passing-benchmarks ( table -- table )
- [ second first2 number? swap number? and ] subset ;
+! : passing-benchmarks ( table -- table )
+! [ second first2 number? swap number? and ] subset ;
-: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+
+! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
: benchmark-difference ( old-table benchmark-result -- result-diff )
first2 >r
@@ -17,7 +19,7 @@ IN: builder.benchmark
2array ;
: compare-tables ( old new -- table )
- [ passing-benchmarks simplify-table ] 2apply
+ [ passing-benchmarks ] 2apply
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
From 3cc32597f83dc86831f3d828b48417f0bc0acab7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 16 Mar 2008 15:57:37 -0600
Subject: [PATCH 055/197] factor.el: minor additions
---
misc/factor.el | 10 +++++++++-
1 file changed, 9 insertions(+), 1 deletion(-)
diff --git a/misc/factor.el b/misc/factor.el
index 5515476c22..7513c3640d 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -158,6 +158,11 @@
(insert str)
(comint-send-input))))
+(defun factor-send-definition ()
+ (interactive)
+ (factor-send-region (search-backward ":")
+ (search-forward ";")))
+
(defun factor-see ()
(interactive)
(comint-send-string "*factor*" "\\ ")
@@ -187,6 +192,7 @@
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
+(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
(define-key factor-mode-map "\C-c\C-s" 'factor-see)
(define-key factor-mode-map "\C-ce" 'factor-edit)
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
@@ -211,4 +217,6 @@
(defun factor-refresh-all ()
(interactive)
- (comint-send-string "*factor*" "refresh-all\n"))
\ No newline at end of file
+ (comint-send-string "*factor*" "refresh-all\n"))
+
+
From 3d2ee2a35c0477804f533585455fece81101e27e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 16 Mar 2008 15:57:56 -0600
Subject: [PATCH 056/197] Add more gl-docs
---
extra/opengl/gl/gl-docs.factor | 19 +++++++++++++++++--
1 file changed, 17 insertions(+), 2 deletions(-)
diff --git a/extra/opengl/gl/gl-docs.factor b/extra/opengl/gl/gl-docs.factor
index 84004cbbdf..f244b4d119 100644
--- a/extra/opengl/gl/gl-docs.factor
+++ b/extra/opengl/gl/gl-docs.factor
@@ -5,7 +5,8 @@ IN: opengl.gl
ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
{ $subsection "opengl-specifying-vertices" }
- { $subsection "opengl-geometric-primitives" } ;
+ { $subsection "opengl-geometric-primitives" }
+ { $subsection "opengl-modeling-transformations" } ;
ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
@@ -67,4 +68,18 @@ HELP: glPolygonMode
{ $list
{ $link GL_POINT }
{ $link GL_LINE }
- { $link GL_FILL } } } } } ;
\ No newline at end of file
+ { $link GL_FILL } } } } } ;
+
+ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+ { $subsection glTranslatef }
+ { $subsection glTranslated }
+ { $subsection glRotatef }
+ { $subsection glRotated }
+ { $subsection glScalef }
+ { $subsection glScaled } ;
+
+
+{ glTranslatef glTranslated glRotatef glRotated glScalef glScaled }
+related-words
+
+
From 53ccdc39542910f2a107f2f4347652e4d94e61b9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 16 Mar 2008 18:36:33 -0700
Subject: [PATCH 057/197] Sketch out windows.com.syntax
---
extra/windows/com/syntax/syntax.factor | 79 ++++++++++++++++++++++----
1 file changed, 69 insertions(+), 10 deletions(-)
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 0895c0e201..9068d75d16 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -1,22 +1,81 @@
-USING: alien alien.c-types kernel windows windows.ole32
-combinators.lib parser splitting sequences.lib ;
+USING: alien alien.c-types kernel windows.ole32
+combinators.lib parser splitting sequences.lib
+sequences namespaces new-slots combinators.cleave
+assocs quotations shuffle ;
IN: windows.com.syntax
<PRIVATE
-: vtbl ( interface -- vtbl )
- *void* ; inline
-: com-invoke ( ... interface n funcptr return parameters -- )
+: com-invoke ( ... interface-ptr n return parameters -- )
"stdcall" [
- swap vtbl swap void*-nth
- ] 4 ndip alien-indirect ;
+ [ *void* ] dip void*-nth
+ ] 3 ndip alien-indirect ; inline
+
+TUPLE: com-interface-definition name parent iid functions ;
+C: <com-interface-definition> com-interface-definition
+
+TUPLE: com-function-definition name return parameters ;
+C: <com-function-definition> com-function-definition
+
+SYMBOL: +com-interface-definitions+
+H{ } +com-interface-definitions+ set-global
+
+: find-com-interface-definition ( name -- definition )
+ dup "f" = [ drop f ] [
+ dup +com-interface-definitions+ get-global at*
+ [ nip ]
+ [ swap " COM interface hasn't been defined" append throw ]
+ if
+ ] if ;
+
+: save-com-interface-definition ( definition -- )
+ dup name>> +com-interface-definitions+ get-global set-at ;
+
+: (parse-com-function) ( tokens -- definition )
+ [ second ]
+ [ first ]
+ [ 3 tail 2 group [ first ] map "void*" add* ]
+ tri
+ <com-function-definition> ;
+
+: parse-com-functions ( -- functions )
+ ";" parse-tokens { ")" } split
+ [ (parse-com-function) ] map ;
+
+: (iid-word) ( definition -- word )
+ name>> "-iid" append create-in ;
+
+: (function-word) ( function interface -- word )
+ name>> "::" rot name>> 3append create-in ;
+
+: all-functions ( definition -- functions )
+ dup parent>> [ all-functions ] [ { } ] if*
+ swap functions>> append ;
+
+: (define-word-for-function) ( function interface n -- )
+ -rot [ (function-word) swap ] 2keep drop
+ { return>> parameters>> } get-slots
+ [ [ com-invoke ] 3curry ] keep
+ length [ npick ] curry swap compose
+ define ;
+
+: define-words-for-com-interface ( definition -- )
+ [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
+ [
+ dup all-functions
+ [ (define-word-for-function) ] with each-index
+ ]
+ bi ;
PRIVATE>
: COM-INTERFACE:
scan
- parse-inheritance
- ";" parse-tokens { ")" } split
- [
+ scan find-com-interface-definition
+ scan string>guid
+ parse-com-functions
+ <com-interface-definition>
+ dup save-com-interface-definition
+ define-words-for-com-interface
; parsing
From ea2723a5a0661f2c2b8d14adaa31e9912c84cc41 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 23:41:26 -0500
Subject: [PATCH 058/197] Fix serialization of circular structure
---
extra/db/postgresql/lib/lib.factor | 4 +-
extra/db/sqlite/lib/lib.factor | 4 +-
extra/reports/optimizer/optimizer.factor | 28 +++
extra/serialize/serialize-tests.factor | 30 +++-
extra/serialize/serialize.factor | 206 +++++++++++++----------
5 files changed, 177 insertions(+), 95 deletions(-)
create mode 100755 extra/reports/optimizer/optimizer.factor
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index b48c87f0ca..928b51dc59 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -73,7 +73,7 @@ IN: db.postgresql.lib
sql-spec-type {
{ FACTOR-BLOB [
dup [
- binary [ serialize ] with-byte-writer
+ object>bytes
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
@@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ BLOB [ pq-get-blob ] }
{ FACTOR-BLOB [
pq-get-blob
- dup [ binary [ deserialize ] with-byte-reader ] when ] }
+ dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index d630522eb8..2e9248c429 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -94,7 +94,7 @@ IN: db.sqlite.lib
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
- binary [ serialize ] with-byte-writer
+ object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
@@ -131,7 +131,7 @@ IN: db.sqlite.lib
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob
- dup [ binary [ deserialize ] with-byte-reader ] when
+ dup [ bytes>object ] when
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]
diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor
new file mode 100755
index 0000000000..294ec8c979
--- /dev/null
+++ b/extra/reports/optimizer/optimizer.factor
@@ -0,0 +1,28 @@
+USING: assocs words sequences arrays compiler tools.time
+io.styles io prettyprint vocabs kernel sorting generator
+optimizer math ;
+IN: report.optimizer
+
+: count-optimization-passes ( nodes n -- n )
+ >r optimize-1
+ [ r> 1+ count-optimization-passes ] [ drop r> ] if ;
+
+: results
+ [ [ second ] swap compose compare ] curry sort 20 tail*
+ print
+ standard-table-style
+ [
+ [ [ [ pprint-cell ] each ] with-row ] each
+ ] tabular-output ;
+
+: optimizer-report
+ all-words [ compiled? ] subset
+ [
+ dup [
+ word-dataflow nip 1 count-optimization-passes
+ ] benchmark nip 2array
+ ] { } map>assoc
+ [ first ] "Worst number of optimizer passes:" results
+ [ second ] "Worst compile times:" results ;
+
+MAIN: optimizer-report
diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor
index 1831495924..c5734b2ae8 100755
--- a/extra/serialize/serialize-tests.factor
+++ b/extra/serialize/serialize-tests.factor
@@ -4,7 +4,7 @@
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
-combinators.lib ;
+combinators.lib assocs ;
IN: serialize.tests
: test-serialize-cell
@@ -56,19 +56,23 @@ C: <serialize-test> serialize-test
} ;
: check-serialize-1 ( obj -- ? )
+ "=====" print
dup class .
+ dup .
dup
- binary [ serialize ] with-byte-writer
- binary [ deserialize ] with-byte-reader = ;
+ object>bytes
+ bytes>object
+ dup . = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
drop t ! we don't care if numbers aren't interned
] [
+ "=====" print
dup class .
- dup 2array
- binary [ serialize ] with-byte-writer
- binary [ deserialize ] with-byte-reader
+ dup 2array dup .
+ object>bytes
+ bytes>object dup .
first2 eq?
] if ;
@@ -79,3 +83,17 @@ C: <serialize-test> serialize-test
[ t ] [ pi check-serialize-1 ] unit-test
[ serialize ] must-infer
[ deserialize ] must-infer
+
+[ t ] [
+ V{ } dup dup push
+ object>bytes
+ bytes>object
+ dup first eq?
+] unit-test
+
+[ t ] [
+ H{ } dup dup dup set-at
+ object>bytes
+ bytes>object
+ dup keys first eq?
+] unit-test
diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index f573499695..65464d4e32 100755
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -11,8 +11,9 @@ USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables
assocs help.syntax help.markup float-arrays splitting
-io.encodings.string io.encodings.utf8 combinators new-slots
-accessors ;
+io.encodings.string io.encodings.utf8 combinators
+combinators.cleave new-slots accessors locals prettyprint
+compiler.units sequences.private tuples.private ;
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
@@ -69,7 +70,8 @@ GENERIC: (serialize) ( obj -- )
: serialize-shared ( obj quot -- )
>r dup object-id
- [ CHAR: o write1 serialize-cell drop ] r> if* ; inline
+ [ CHAR: o write1 serialize-cell drop ]
+ r> if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
@@ -96,75 +98,93 @@ M: ratio (serialize) ( obj -- )
dup numerator (serialize)
denominator (serialize) ;
-: serialize-string ( obj code -- )
- write1
- dup utf8 encode dup length serialize-cell write
- add-object ;
-
-M: string (serialize) ( obj -- )
- [ CHAR: s serialize-string ] serialize-shared ;
-
-: serialize-elements ( seq -- )
- [ (serialize) ] each CHAR: . write1 ;
+: serialize-seq ( obj code -- )
+ [
+ write1
+ [ add-object ]
+ [ length serialize-cell ]
+ [ [ (serialize) ] each ] tri
+ ] curry serialize-shared ;
M: tuple (serialize) ( obj -- )
[
CHAR: T write1
- dup tuple>array serialize-elements
- add-object
+ [ class (serialize) ]
+ [ add-object ]
+ [ tuple>array 1 tail (serialize) ]
+ tri
] serialize-shared ;
-: serialize-seq ( seq code -- )
- [
- write1
- dup serialize-elements
- add-object
- ] curry serialize-shared ;
-
M: array (serialize) ( obj -- )
CHAR: a serialize-seq ;
-M: byte-array (serialize) ( obj -- )
- [
- CHAR: A write1
- dup dup length serialize-cell write
- add-object
- ] serialize-shared ;
-
-M: bit-array (serialize) ( obj -- )
- [
- CHAR: b write1
- dup length serialize-cell
- dup [ 1 0 ? ] B{ } map-as write
- add-object
- ] serialize-shared ;
-
M: quotation (serialize) ( obj -- )
- CHAR: q serialize-seq ;
-
-M: float-array (serialize) ( obj -- )
[
- CHAR: f write1
- dup length serialize-cell
- dup [ double>bits 8 >be write ] each
- add-object
+ CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
[
CHAR: h write1
- dup >alist (serialize)
- add-object
+ [ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
-M: word (serialize) ( obj -- )
+M: bit-array (serialize) ( obj -- )
+ CHAR: b serialize-seq ;
+
+M: byte-array (serialize) ( obj -- )
[
- CHAR: w write1
- dup word-name (serialize)
- dup word-vocabulary (serialize)
- add-object
+ CHAR: A write1
+ [ add-object ]
+ [ length serialize-cell ]
+ [ write ] tri
] serialize-shared ;
+M: float-array (serialize) ( obj -- )
+ [
+ CHAR: f write1
+ [ add-object ]
+ [ length serialize-cell ]
+ [ [ double>bits 8 >be write ] each ]
+ tri
+ ] serialize-shared ;
+
+M: string (serialize) ( obj -- )
+ [
+ CHAR: s write1
+ [ add-object ]
+ [
+ utf8 encode
+ [ length serialize-cell ]
+ [ write ] bi
+ ] bi
+ ] serialize-shared ;
+
+: serialize-true ( word -- )
+ drop CHAR: t write1 ;
+
+: serialize-gensym ( word -- )
+ [
+ CHAR: G write1
+ [ add-object ]
+ [ word-def (serialize) ]
+ [ word-props (serialize) ]
+ tri
+ ] serialize-shared ;
+
+: serialize-word ( word -- )
+ CHAR: w write1
+ [ word-name (serialize) ]
+ [ word-vocabulary (serialize) ]
+ bi ;
+
+M: word (serialize) ( obj -- )
+ {
+ { [ dup t eq? ] [ serialize-true ] }
+ { [ dup word-vocabulary not ] [ serialize-gensym ] }
+ { [ t ] [ serialize-word ] }
+ } cond ;
+
M: wrapper (serialize) ( obj -- )
CHAR: W write1
wrapped (serialize) ;
@@ -179,6 +199,9 @@ SYMBOL: deserialized
: deserialize-false ( -- f )
f ;
+: deserialize-true ( -- f )
+ t ;
+
: deserialize-positive-integer ( -- number )
deserialize-cell ;
@@ -204,53 +227,63 @@ SYMBOL: deserialized
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
- (deserialize) dup (deserialize) lookup
- [ dup intern-object ] [ "Unknown word" throw ] ?if ;
+ (deserialize) (deserialize) 2dup lookup
+ dup [ 2nip ] [
+ "Unknown word: " -rot
+ 2array unparse append throw
+ ] if ;
+
+: deserialize-gensym ( -- word )
+ gensym
+ dup intern-object
+ dup (deserialize) define
+ dup (deserialize) swap set-word-props ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
-SYMBOL: +stop+
-
-: (deserialize-seq) ( -- seq )
- [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
-
-: deserialize-seq ( seq -- array )
- >r (deserialize-seq) r> like dup intern-object ;
+:: (deserialize-seq) ( exemplar quot -- seq )
+ deserialize-cell exemplar new
+ [ intern-object ]
+ [ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-array ( -- array )
- { } deserialize-seq ;
+ { } [ (deserialize) ] (deserialize-seq) ;
: deserialize-quotation ( -- array )
- [ ] deserialize-seq ;
-
-: (deserialize-byte-array) ( -- byte-array )
- deserialize-cell read B{ } like ;
+ (deserialize) >quotation dup intern-object ;
: deserialize-byte-array ( -- byte-array )
- (deserialize-byte-array) dup intern-object ;
+ B{ } [ read1 ] (deserialize-seq) ;
: deserialize-bit-array ( -- bit-array )
- (deserialize-byte-array) [ 0 > ] ?{ } map-as
- dup intern-object ;
+ ?{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-float-array ( -- float-array )
- deserialize-cell
- 8 * read 8 <groups> [ be> bits>double ] F{ } map-as
- dup intern-object ;
+ F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
: deserialize-hashtable ( -- hashtable )
- (deserialize) >hashtable dup intern-object ;
+ H{ } clone
+ [ intern-object ]
+ [ (deserialize) update ]
+ [ ] tri ;
+
+: copy-seq-to-tuple ( seq tuple -- )
+ >r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
- (deserialize-seq) >tuple dup intern-object ;
+ #! Ugly because we have to intern the tuple before reading
+ #! slots
+ (deserialize) construct-empty
+ [ intern-object ]
+ [
+ [ (deserialize) ]
+ [ [ copy-seq-to-tuple ] keep ] bi*
+ ] bi ;
: deserialize-unknown ( -- object )
deserialize-cell deserialized get nth ;
-: deserialize-stop ( -- object )
- +stop+ get ;
-
: deserialize* ( -- object ? )
read1 [
{
@@ -265,14 +298,15 @@ SYMBOL: +stop+
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
+ { CHAR: t [ deserialize-true ] }
{ CHAR: o [ deserialize-unknown ] }
{ CHAR: p [ deserialize-positive-integer ] }
{ CHAR: q [ deserialize-quotation ] }
{ CHAR: r [ deserialize-ratio ] }
{ CHAR: s [ deserialize-string ] }
{ CHAR: w [ deserialize-word ] }
+ { CHAR: G [ deserialize-word ] }
{ CHAR: z [ deserialize-zero ] }
- { CHAR: . [ deserialize-stop ] }
} case t
] [
f f
@@ -283,13 +317,15 @@ SYMBOL: +stop+
: deserialize ( -- obj )
[
- V{ } clone deserialized set
- gensym +stop+ set
- (deserialize)
- ] with-scope ;
+ V{ } clone deserialized
+ [ (deserialize) ] with-variable
+ ] with-compilation-unit ;
: serialize ( obj -- )
- [
- H{ } clone serialized set
- (serialize)
- ] with-scope ;
\ No newline at end of file
+ H{ } clone serialized [ (serialize) ] with-variable ;
+
+: bytes>object ( bytes -- obj )
+ binary [ deserialize ] with-byte-reader ;
+
+: object>bytes ( obj -- bytes )
+ binary [ serialize ] with-byte-writer ;
\ No newline at end of file
From 2947297cefc8e60fe1524f6ae9825992775a7c17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 23:42:21 -0500
Subject: [PATCH 059/197] Reports
---
extra/reports/noise/noise.factor | 129 +++++++++++++++++++++++
extra/reports/optimizer/optimizer.factor | 17 +--
2 files changed, 140 insertions(+), 6 deletions(-)
create mode 100755 extra/reports/noise/noise.factor
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
new file mode 100755
index 0000000000..230eef523e
--- /dev/null
+++ b/extra/reports/noise/noise.factor
@@ -0,0 +1,129 @@
+USING: assocs math kernel shuffle combinators.lib
+words quotations arrays combinators sequences math.vectors
+io.styles combinators.cleave prettyprint vocabs sorting io
+generic locals.private ;
+IN: reports.noise
+
+: badness ( word -- n )
+ H{
+ { -nrot 5 }
+ { -roll 4 }
+ { -rot 3 }
+ { 2apply 1 }
+ { 2curry 1 }
+ { 2drop 1 }
+ { 2dup 2 }
+ { 2keep 2 }
+ { 2nip 3 }
+ { 2over 4 }
+ { 2slip 2 }
+ { 2swap 3 }
+ { 2with 2 }
+ { 2with* 3 }
+ { 3apply 1/2 }
+ { 3curry 2 }
+ { 3drop 1 }
+ { 3dup 2 }
+ { 3keep 3 }
+ { 3nip 4 }
+ { 3slip 3 }
+ { 3with 3 }
+ { 3with* 4 }
+ { 4drop 2 }
+ { 4dup 3 }
+ { 4slip 4 }
+ { compose 1/2 }
+ { curry 1/2 }
+ { dip 1 }
+ { dipd 2 }
+ { drop 1/2 }
+ { dup 1/2 }
+ { keep 1 }
+ { napply 2 }
+ { ncurry 3 }
+ { ndip 5 }
+ { ndrop 2 }
+ { ndup 3 }
+ { nip 2 }
+ { nipd 3 }
+ { nkeep 5 }
+ { npick 6 }
+ { nrev 5 }
+ { nrot 5 }
+ { nslip 5 }
+ { ntuck 6 }
+ { nwith 4 }
+ { over 2 }
+ { pick 4 }
+ { roll 4 }
+ { rot 3 }
+ { slip 1 }
+ { spin 3 }
+ { swap 1 }
+ { swapd 3 }
+ { tuck 2 }
+ { tuckd 3 }
+ { with 1 }
+ { with* 2 }
+ { r> 1/2 }
+ { >r 1/2 }
+
+ { bi 1/2 }
+ { tri 1 }
+ { bi* 1/2 }
+ { tri* 1 }
+
+ { cleave 2 }
+ { spread 2 }
+ } at 0 or ;
+
+: vsum { 0 0 } [ v+ ] reduce ;
+
+GENERIC: noise ( obj -- pair )
+
+M: word noise badness 1 2array ;
+
+M: wrapper noise wrapped noise ;
+
+M: let noise let-body noise ;
+
+M: wlet noise wlet-body noise ;
+
+M: lambda noise lambda-body noise ;
+
+M: object noise drop { 0 0 } ;
+
+M: quotation noise [ noise ] map vsum { 1/3 0 } v+ ;
+
+M: array noise [ noise ] map vsum { 1/3 0 } v+ ;
+
+: quot-noise-factor ( quot -- n )
+ #! For very short words, noise doesn't count so much
+ #! (so dup foo swap bar isn't penalized as badly).
+ noise first2 15 max / 100 * >integer ;
+
+GENERIC: word-noise-factor ( word -- factor )
+
+M: word word-noise-factor
+ word-def quot-noise-factor ;
+
+M: lambda-word word-noise-factor
+ "lambda" word-prop quot-noise-factor ;
+
+: noisy-words ( -- alist )
+ all-words [
+ dup generic? [ methods values ] [ 1array ] if
+ ] map concat [ dup word-noise-factor ] { } map>assoc
+ sort-values reverse ;
+
+: noisy-words. ( alist -- )
+ standard-table-style [
+ [
+ [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
+ ] assoc-each
+ ] tabular-output ;
+
+: noise-report ( -- )
+ noisy-words 40 head noisy-words. ;
+
+MAIN: noise-report
diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor
index 294ec8c979..42e72dee45 100755
--- a/extra/reports/optimizer/optimizer.factor
+++ b/extra/reports/optimizer/optimizer.factor
@@ -1,6 +1,6 @@
USING: assocs words sequences arrays compiler tools.time
io.styles io prettyprint vocabs kernel sorting generator
-optimizer math ;
+optimizer math combinators.cleave ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
@@ -13,16 +13,21 @@ IN: report.optimizer
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
- ] tabular-output ;
+ ] tabular-output ; inline
-: optimizer-report
+: optimizer-measurements ( -- alist )
all-words [ compiled? ] subset
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark nip 2array
- ] { } map>assoc
- [ first ] "Worst number of optimizer passes:" results
- [ second ] "Worst compile times:" results ;
+ ] { } map>assoc ;
+
+: optimizer-measurements. ( alist -- )
+ [ [ first ] "Worst number of optimizer passes:" results ]
+ [ [ second ] "Worst compile times:" results ] bi ;
+
+: optimizer-report ( -- )
+ optimizer-measurements optimizer-measurements. ;
MAIN: optimizer-report
From 16e6f36fc97ef2ddd2880b0775007ead904e822f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 17 Mar 2008 00:26:05 -0500
Subject: [PATCH 060/197] refactor db start on random-id
---
extra/db/db.factor | 24 ++++++++++++++++-
extra/db/postgresql/postgresql.factor | 3 ++-
extra/db/sqlite/sqlite.factor | 25 ++++++++++++++----
extra/db/tuples/tuples-tests.factor | 8 +++---
extra/db/tuples/tuples.factor | 16 +++++++-----
extra/db/types/types.factor | 37 +++++++++++++++------------
6 files changed, 79 insertions(+), 34 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 309847209f..ac46be4422 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
+TUPLE: nonthrowable-statement ;
+: make-nonthrowable ( obj -- obj' )
+ dup sequence? [
+ [ make-nonthrowable ] map
+ ] [
+ nonthrowable-statement construct-delegate
+ ] if ;
+
+MIXIN: throwable-statement
+INSTANCE: statement throwable-statement
+INSTANCE: simple-statement throwable-statement
+INSTANCE: prepared-statement throwable-statement
+
TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( sql in out -- statement )
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
@@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
-: execute-statement ( statement -- )
+GENERIC: execute-statement ( statement -- )
+
+M: throwable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
+M: nonthrowable-statement execute-statement ( statement -- )
+ dup sequence? [
+ [ execute-statement ] each
+ ] [
+ [ query-results dispose ] [ 2drop ] recover
+ ] if ;
+
: bind-statement ( obj statement -- )
swap >>bind-params
[ bind-statement* ] keep
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index b2042c98bd..8a6f8632ec 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -10,6 +10,7 @@ IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
+INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
@@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
");" 0%
] postgresql-make ;
-M: postgresql-db <insert-assigned-statement> ( class -- statement )
+M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index b8ef5c7b17..1b594d6fa4 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
combinators.cleave io namespaces.lib ;
+USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db path ;
@@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
+INSTANCE: sqlite-statement throwable-statement
+
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
@@ -33,13 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
set-statement-in-params
set-statement-out-params
} statement construct
- db get db-handle over statement-sql sqlite-prepare
- over set-statement-handle
sqlite-statement construct-delegate ;
+: sqlite-maybe-prepare ( statement -- statement )
+ dup statement-handle [
+ [
+ delegate
+ db get db-handle over statement-sql sqlite-prepare
+ swap set-statement-handle
+ ] keep
+ ] unless ;
+
M: sqlite-statement dispose ( statement -- )
statement-handle
- [ sqlite3_reset drop ] keep sqlite-finalize ;
+ [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
@@ -47,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
-: reset-statement ( statement -- ) statement-handle sqlite-reset ;
+: reset-statement ( statement -- )
+ sqlite-maybe-prepare
+ statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
+ sqlite-maybe-prepare
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi
sqlite-bind ;
@@ -90,6 +103,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
+ sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
@@ -126,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
");" 0%
] sqlite-make ;
-M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
@@ -176,6 +190,7 @@ M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
+ ! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 8e347490e4..2dbf6d1008 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -9,7 +9,7 @@ IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
-: <person> ( name age real ts date time blob -- person )
+: <person> ( name age real ts date time blob factor-blob -- person )
{
set-person-the-name
set-person-the-number
@@ -190,18 +190,16 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-postgresql ( -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
-[ native-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-tuples ] test-sqlite
-
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
-
[ assigned-person-schema test-repeated-insert ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-postgresql
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index d50e42c0fb..0f69b0fafb 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( class -- obj )
+HOOK: <insert-nonnative-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
@@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
- [ dup drop-table ] ignore-errors create-table ;
+ [
+ drop-sql-statement make-nonthrowable
+ [ execute-statement ] with-disposals
+ ] [ create-table ] bi ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
-: insert-assigned ( tuple -- )
+: insert-nonnative ( tuple -- )
+! TODO logic here for unique ids
dup class
- db get db-insert-statements [ <insert-assigned-statement> ] cache
+ db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key assigned-id? [
- insert-assigned
+ dup class db-columns find-primary-key nonnative-id? [
+ insert-nonnative
] [
insert-native
] if ;
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 7014aaa943..532c097957 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -3,7 +3,8 @@
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols ;
+mirrors tuples combinators calendar.format symbols
+singleton ;
IN: db.types
HOOK: modifier-table db ( -- hash )
@@ -14,22 +15,32 @@ HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
-SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
-+serial+ +unique+ +default+ +null+ +not-null+
+
+SINGLETON: +native-id+
+SINGLETON: +assigned-id+
+SINGLETON: +random-id+
+UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
+UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
+
+! +native-id+ +assigned-id+ +random-assigned-id+
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
-: (primary-key?) ( obj -- ? )
- { +native-id+ +assigned-id+ } member? ;
-
: primary-key? ( spec -- ? )
- sql-spec-primary-key (primary-key?) ;
+ sql-spec-primary-key +primary-key+? ;
+
+: native-id? ( spec -- ? )
+ sql-spec-primary-key +native-id+? ;
+
+: nonnative-id? ( spec -- ? )
+ sql-spec-primary-key +nonnative-id+? ;
: normalize-spec ( spec -- )
- dup sql-spec-type dup (primary-key?) [
+ dup sql-spec-type dup +primary-key+? [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
- (primary-key?)
+ +primary-key+?
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
@@ -37,12 +48,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
-: native-id? ( spec -- ? )
- sql-spec-primary-key +native-id+ = ;
-
-: assigned-id? ( spec -- ? )
- sql-spec-primary-key +assigned-id+ = ;
-
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
@@ -69,7 +74,7 @@ TUPLE: no-sql-modifier ;
dup number? [ number>string ] when ;
: maybe-remove-id ( specs -- obj )
- [ native-id? not ] subset ;
+ [ +native-id+? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;
From 7f11c9fe3a26e8326118b7ad670a30c151b59588 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 17 Mar 2008 03:27:41 -0500
Subject: [PATCH 061/197] Fix delegate
---
extra/delegate/delegate.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 9eabfae95c..67b8a39320 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -27,11 +27,11 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
- pick add spin define-method ;
+ pick add >r swap create-method r> define ;
: define-consult ( class group quot -- )
- >r group-words r>
- swapd [ define-consult-method ] 2curry each ;
+ >r group-words swap r>
+ [ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition swapd define-consult ; parsing
@@ -39,7 +39,7 @@ M: tuple-class group-words
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
- [ "method-def" word-prop spin define-method ]
+ [ >r swap create-method r> word-def define ]
[ 3drop ] if
] 2curry each ;
From 9d2d1c53475533c90351f1275b4f278e8c3b965b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 17 Mar 2008 03:28:07 -0500
Subject: [PATCH 062/197] Fix serialize
---
extra/serialize/serialize.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index 65464d4e32..86fadf55bf 100755
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -6,14 +6,14 @@
!
! See http://factorcode.org/license.txt for BSD license.
!
-IN: serialize
USING: namespaces sequences kernel math io math.functions
-io.binary strings classes words sbufs tuples arrays
-vectors byte-arrays bit-arrays quotations hashtables
-assocs help.syntax help.markup float-arrays splitting
-io.encodings.string io.encodings.utf8 combinators
-combinators.cleave new-slots accessors locals prettyprint
-compiler.units sequences.private tuples.private ;
+io.binary strings classes words sbufs tuples arrays vectors
+byte-arrays bit-arrays quotations hashtables assocs help.syntax
+help.markup float-arrays splitting io.streams.byte-array
+io.encodings.string io.encodings.utf8 io.encodings.binary
+combinators combinators.cleave new-slots accessors locals
+prettyprint compiler.units sequences.private tuples.private ;
+IN: serialize
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
From d4be6ea98c6d3feb56f28dfc362ab8fd865f2ac7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 17 Mar 2008 04:31:13 -0500
Subject: [PATCH 063/197] Working on HTTP server
---
extra/http/http-tests.factor | 4 +-
extra/http/server/actions/actions.factor | 17 ++--
extra/http/server/auth/auth.factor | 19 ++++-
extra/http/server/auth/login/login.factor | 34 +++++---
.../auth/providers/assoc/assoc-tests.factor | 6 +-
.../server/auth/providers/db/db-tests.factor | 20 +++--
.../server/auth/providers/providers.factor | 11 +--
extra/http/server/callbacks/callbacks.factor | 15 +++-
extra/http/server/server.factor | 27 +++---
.../server/sessions/sessions-tests.factor | 41 +++++++--
extra/http/server/sessions/sessions.factor | 7 +-
.../http/server/sessions/storage/db/db.factor | 14 +---
extra/openssl/openssl-tests.factor | 38 ++++-----
extra/reports/noise/noise.factor | 83 ++++++++++++++-----
extra/tools/walker/walker.factor | 24 +++++-
15 files changed, 239 insertions(+), 121 deletions(-)
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 66182b10ae..2e7370bc39 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -5,8 +5,8 @@ IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
-[ "" ] [ "%XX%XX%X" url-decode ] unit-test
+[ f ] [ "%XX%XX%XX" url-decode ] unit-test
+[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 91671392c7..52567ed352 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -38,10 +38,13 @@ TUPLE: action init display submit get-params post-params ;
action get display>> call exit-with ;
M: action call-responder ( path action -- response )
- [ +path+ associate request-params union params set ]
- [ action set ] bi*
- request get method>> {
- { "GET" [ handle-get ] }
- { "HEAD" [ handle-get ] }
- { "POST" [ handle-post ] }
- } case ;
+ '[
+ , ,
+ [ +path+ associate request-params union params set ]
+ [ action set ] bi*
+ request get method>> {
+ { "GET" [ handle-get ] }
+ { "HEAD" [ handle-get ] }
+ { "POST" [ handle-post ] }
+ } case
+ ] with-exit-continuation ;
diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor
index 1b1534b85e..69a3c76c2b 100755
--- a/extra/http/server/auth/auth.factor
+++ b/extra/http/server/auth/auth.factor
@@ -1,9 +1,26 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.sessions accessors
-http.server.auth.providers ;
+http.server.auth.providers assocs namespaces kernel ;
IN: http.server.auth
SYMBOL: logged-in-user
+SYMBOL: user-profile-changed?
+
+GENERIC: init-user-profile ( responder -- )
+
+M: object init-user-profile drop ;
: uid ( -- string ) logged-in-user sget username>> ;
+
+: profile ( -- assoc ) logged-in-user sget profile>> ;
+
+: uget ( key -- value )
+ profile at ;
+
+: uset ( value key -- )
+ profile set-at user-profile-changed? on ;
+
+: uchange ( quot key -- )
+ profile swap change-at
+ user-profile-changed? on ; inline
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index a1c99f749c..275fb0ff63 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -7,16 +7,29 @@ http.server.actions http.server.components http.server.sessions
http.server.templating.fhtml http.server.validators
http.server.auth http sequences io.files namespaces hashtables
fry io.sockets combinators.cleave arrays threads locals
-qualified ;
+qualified continuations destructors ;
IN: http.server.auth.login
QUALIFIED: smtp
+SYMBOL: post-login-url
+SYMBOL: login-failed?
+
TUPLE: login users ;
: users login get users>> ;
-SYMBOL: post-login-url
-SYMBOL: login-failed?
+! Destructor
+TUPLE: user-saver user ;
+
+C: <user-saver> user-saver
+
+M: user-saver dispose
+ user-profile-changed? get [
+ user>> users update-user
+ ] [ drop ] if ;
+
+: save-user-after ( user -- )
+ <user-saver> add-always-destructor ;
! ! ! Login
@@ -116,6 +129,8 @@ SYMBOL: user-exists?
] unless*
successful-login
+
+ login get responder>> init-user-profile
] >>submit
] ;
@@ -155,23 +170,21 @@ SYMBOL: previous-page
form validate-form
+ logged-in-user sget
+
"password" value empty? [
- logged-in-user sget
- ] [
same-password-twice
"password" value uid users check-login
[ login-failed? on validation-failed ] unless
- "new-password" value uid users set-password
- [ "User deleted" throw ] unless*
- ] if
+ "new-password" value set-password
+ ] unless
"realname" value >>realname
"email" value >>email
- dup users update-user
- logged-in-user sset
+ user-profile-changed? on
previous-page sget f <permanent-redirect>
] >>submit
@@ -330,6 +343,7 @@ C: <protected> protected
M: protected call-responder ( path responder -- response )
logged-in-user sget [
+ dup save-user-after
request get request-url previous-page sset
responder>> call-responder
] [
diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor
index ae4c5d051f..f99e4d3d2e 100755
--- a/extra/http/server/auth/providers/assoc/assoc-tests.factor
+++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor
@@ -22,11 +22,11 @@ namespaces accessors kernel ;
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
-[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
+[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
-[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
+[ t ] [ "user" get >boolean ] unit-test
-[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
+[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor
index 1ee7278163..340e1bb35d 100755
--- a/extra/http/server/auth/providers/db/db-tests.factor
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@@ -12,26 +12,28 @@ users-in-db "provider" set
[ t ] [
<user>
- "slava" >>username
- "foobar" >>password
- "slava@factorcode.org" >>email
- "provider" get new-user
- username>> "slava" =
+ "slava" >>username
+ "foobar" >>password
+ "slava@factorcode.org" >>email
+ "provider" get new-user
+ username>> "slava" =
] unit-test
[ f ] [
<user>
- "slava" >>username
+ "slava" >>username
"provider" get new-user
] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
- [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
+ [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
- [ f ] [ "xx" "blah" "provider" get set-password ] unit-test
+ [ t ] [ "user" get >boolean ] unit-test
- [ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
+ [ ] [ "user" get "fdasf" set-password drop ] unit-test
+
+ [ ] [ "user" get "provider" get update-user ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index cd9cc995c7..d51679016e 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel new-slots accessors random math.parser locals
-sequences math ;
+sequences math crypto.sha2 ;
IN: http.server.auth.providers
TUPLE: user username realname password email ticket profile ;
@@ -17,14 +17,7 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
-:: set-password ( password username provider -- user/f )
- [let | user [ username provider get-user ] |
- user [
- user
- password >>password
- dup provider update-user
- ] [ f ] if
- ] ;
+: set-password ( user password -- user ) >>password ;
! Password recovery support
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
index 45a6ff85f8..eb264279cb 100755
--- a/extra/http/server/callbacks/callbacks.factor
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -98,11 +98,18 @@ SYMBOL: current-show
cont-id query-param swap callbacks>> at ;
M: callback-responder call-responder ( path responder -- response )
- [ callback-responder set ]
- [ request get resuming-callback ] bi
+ '[
+ , ,
- [ invoke-callback ]
- [ callback-responder get responder>> call-responder ] ?if ;
+ [ callback-responder set ]
+ [ request get resuming-callback ] bi
+
+ [
+ invoke-callback
+ ] [
+ callback-responder get responder>> call-responder
+ ] ?if
+ ] with-exit-continuation ;
: show-page ( quot -- )
>r redirect-to-here store-current-show r>
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index ce6a1244cb..7448752c60 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -185,21 +185,20 @@ SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
+: with-exit-continuation ( quot -- )
+ '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+
: do-request ( request -- response )
- '[
- exit-continuation set ,
- [
- [ log-request ]
- [ request set ]
- [ path>> main-responder get call-responder ] tri
- [ <404> ] unless*
- ] [
- [ \ do-request log-error ]
- [ <500> ]
- bi
- ] recover
- ] callcc1
- exit-continuation off ;
+ [
+ [ log-request ]
+ [ request set ]
+ [ path>> main-responder get call-responder ] tri
+ [ <404> ] unless*
+ ] [
+ [ \ do-request log-error ]
+ [ <500> ]
+ bi
+ ] recover ;
: default-timeout 1 minutes stdio get set-timeout ;
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index a6a42f9129..26e6927d7c 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -1,8 +1,8 @@
IN: http.server.sessions.tests
USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc
-http.server math namespaces kernel accessors prettyprint
-io.streams.string splitting destructors ;
+http.server.actions http.server math namespaces kernel accessors
+prettyprint io.streams.string splitting destructors sequences ;
[ H{ } ] [ H{ } add-session-id ] unit-test
@@ -72,9 +72,9 @@ M: foo call-responder
: url-responder-mock-test
[
<request>
- "GET" >>method
- "id" get session-id-key set-query-param
- "/" >>path
+ "GET" >>method
+ "id" get session-id-key set-query-param
+ "/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
@@ -107,9 +107,9 @@ response set
: cookie-responder-mock-test
[
<request>
- "GET" >>method
- "cookies" get >>cookies
- "/" >>path
+ "GET" >>method
+ "cookies" get >>cookies
+ "/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
@@ -118,3 +118,28 @@ response set
[ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test
+
+: <exiting-action>
+ <action>
+ [
+ "text/plain" <content> exit-with
+ ] >>display ;
+
+[
+ [ ] [
+ <request>
+ "GET" >>method
+ "id" get session-id-key set-query-param
+ "/" >>path
+ request set
+
+ [
+ "/" <exiting-action> <cookie-sessions>
+ call-responder
+ ] with-destructors response set
+ ] unit-test
+
+ [ "text/plain" ] [ response get "content-type" header ] unit-test
+
+ [ f ] [ response get cookies>> empty? ] unit-test
+] with-scope
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index 76f022e28c..f45f10d25f 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -13,7 +13,7 @@ IN: http.server.sessions
GENERIC: init-session* ( responder -- )
-M: dispatcher init-session* drop ;
+M: object init-session* drop ;
TUPLE: session-manager responder sessions ;
@@ -56,8 +56,11 @@ M: session-saver dispose
sessions update-session
] [ drop ] if ;
+: save-session-after ( id session -- )
+ <session-saver> add-always-destructor ;
+
: call-responder/session ( path responder id session -- response )
- [ <session-saver> add-always-destructor ]
+ [ save-session-after ]
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
index 6ef655bde2..07cd22bc62 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -21,23 +21,18 @@ session "SESSIONS"
session construct-empty
swap dup [ string>number ] when >>id ;
-USING: namespaces io prettyprint ;
M: sessions-in-db get-session ( id storage -- namespace/f )
- global [ "get " write over print flush ] bind
drop
dup [
<session>
- select-tuple dup [ namespace>> ] when global [ dup . ] bind
+ select-tuple dup [ namespace>> ] when
] when ;
M: sessions-in-db update-session ( namespace id storage -- )
- global [ "update " write over print flush ] bind
drop
<session>
- swap global [ dup . ] bind >>namespace
- dup update-tuple
- id>> <session> select-tuple global [ . flush ] bind
- ;
+ swap >>namespace
+ update-tuple ;
M: sessions-in-db delete-session ( id storage -- )
drop
@@ -45,8 +40,7 @@ M: sessions-in-db delete-session ( id storage -- )
delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id )
- global [ "new " print flush ] bind
drop
f <session>
- swap global [ dup . ] bind >>namespace
+ swap >>namespace
[ insert-tuple ] [ id>> number>string ] bi ;
diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor
index c40bc5628b..2d0f5bb5d0 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@@ -21,55 +21,55 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
! Initialize context
! =========================================================
-init load-error-strings
+[ ] [ init load-error-strings ] unit-test
-ssl-v23 new-ctx
+[ ] [ ssl-v23 new-ctx ] unit-test
-get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain
+[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
-get-ctx "password" string>char-alien set-default-passwd-userdata
+[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
-get-ctx "/extra/openssl/test/server.pem" resource-path
-SSL_FILETYPE_PEM use-private-key
+[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
+SSL_FILETYPE_PEM use-private-key ] unit-test
-get-ctx "/extra/openssl/test/root.pem" resource-path f
-verify-load-locations
+[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
+verify-load-locations ] unit-test
-get-ctx 1 set-verify-depth
+[ ] [ get-ctx 1 set-verify-depth ] unit-test
! =========================================================
! Load Diffie-Hellman parameters
! =========================================================
-"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file
+[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
-get-bio f f f read-pem-dh-params
+[ ] [ get-bio f f f read-pem-dh-params ] unit-test
-get-bio bio-free
+[ ] [ get-bio bio-free ] unit-test
! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
-! get-ctx get-dh set-tmp-dh-callback
+[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
! Workaround (this function should never be called directly)
-get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl
+! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
! =========================================================
! Generate ephemeral RSA key
! =========================================================
-512 RSA_F4 f f generate-rsa-key
+[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
! get-ctx get-rsa set-tmp-rsa-callback
! Workaround (this function should never be called directly)
-get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl
+[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
-get-rsa free-rsa
+[ ] [ get-rsa free-rsa ] unit-test
! =========================================================
! Listen and accept on socket
@@ -129,11 +129,11 @@ get-rsa free-rsa
! Dump errors to file
! =========================================================
-"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file
+[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
-get-bio bio-free
+[ ] [ get-bio bio-free ] unit-test
! =========================================================
! Clean-up
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 230eef523e..f4b10a7d81 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -1,7 +1,7 @@
USING: assocs math kernel shuffle combinators.lib
words quotations arrays combinators sequences math.vectors
io.styles combinators.cleave prettyprint vocabs sorting io
-generic locals.private ;
+generic locals.private math.statistics ;
IN: reports.noise
: badness ( word -- n )
@@ -12,9 +12,9 @@ IN: reports.noise
{ 2apply 1 }
{ 2curry 1 }
{ 2drop 1 }
- { 2dup 2 }
- { 2keep 2 }
- { 2nip 3 }
+ { 2dup 1 }
+ { 2keep 1 }
+ { 2nip 2 }
{ 2over 4 }
{ 2slip 2 }
{ 2swap 3 }
@@ -33,11 +33,19 @@ IN: reports.noise
{ 4dup 3 }
{ 4slip 4 }
{ compose 1/2 }
- { curry 1/2 }
+ { curry 1/3 }
{ dip 1 }
{ dipd 2 }
- { drop 1/2 }
- { dup 1/2 }
+ { drop 1/3 }
+ { dup 1/3 }
+ { if 1/3 }
+ { when 1/4 }
+ { unless 1/4 }
+ { when* 1/3 }
+ { unless* 1/3 }
+ { ?if 1/2 }
+ { cond 1/2 }
+ { case 1/2 }
{ keep 1 }
{ napply 2 }
{ ncurry 3 }
@@ -62,11 +70,11 @@ IN: reports.noise
{ swap 1 }
{ swapd 3 }
{ tuck 2 }
- { tuckd 3 }
- { with 1 }
+ { tuckd 4 }
+ { with 1/2 }
{ with* 2 }
- { r> 1/2 }
- { >r 1/2 }
+ { r> 1 }
+ { >r 1 }
{ bi 1/2 }
{ tri 1 }
@@ -93,14 +101,30 @@ M: lambda noise lambda-body noise ;
M: object noise drop { 0 0 } ;
-M: quotation noise [ noise ] map vsum { 1/3 0 } v+ ;
+M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
-M: array noise [ noise ] map vsum { 1/3 0 } v+ ;
+M: array noise [ noise ] map vsum ;
+
+: noise-factor / 100 * >integer ;
: quot-noise-factor ( quot -- n )
#! For very short words, noise doesn't count so much
#! (so dup foo swap bar isn't penalized as badly).
- noise first2 15 max / 100 * >integer ;
+ noise first2 {
+ { [ over 4 <= ] [ >r drop 0 r> ] }
+ { [ over 15 >= ] [ >r 2 * r> ] }
+ { [ t ] [ ] }
+ } cond
+ {
+ ! short words are easier to read
+ { [ dup 10 <= ] [ >r 2 / r> ] }
+ { [ dup 5 <= ] [ >r 3 / r> ] }
+ ! long words are penalized even more
+ { [ dup 25 >= ] [ >r 2 * r> 20 max ] }
+ { [ dup 20 >= ] [ >r 5/3 * r> ] }
+ { [ dup 15 >= ] [ >r 3/2 * r> ] }
+ { [ t ] [ ] }
+ } cond noise-factor ;
GENERIC: word-noise-factor ( word -- factor )
@@ -110,20 +134,41 @@ M: word word-noise-factor
M: lambda-word word-noise-factor
"lambda" word-prop quot-noise-factor ;
-: noisy-words ( -- alist )
- all-words [
+: flatten-generics ( words -- words' )
+ [
dup generic? [ methods values ] [ 1array ] if
- ] map concat [ dup word-noise-factor ] { } map>assoc
+ ] map concat ;
+
+: noisy-words ( -- alist )
+ all-words flatten-generics
+ [ dup word-noise-factor ] { } map>assoc
sort-values reverse ;
-: noisy-words. ( alist -- )
+: noise. ( alist -- )
standard-table-style [
[
[ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
] assoc-each
] tabular-output ;
+: vocab-noise-factor ( vocab -- factor )
+ words flatten-generics
+ [ word-noise-factor dup 20 < [ drop 0 ] when ] map
+ dup empty? [ drop 0 ] [
+ [ [ sum ] [ length 5 max ] bi /i ]
+ [ supremum ]
+ bi +
+ ] if ;
+
+: noisy-vocabs ( -- alist )
+ vocabs [ dup vocab-noise-factor ] { } map>assoc
+ sort-values reverse ;
+
: noise-report ( -- )
- noisy-words 40 head noisy-words. ;
+ "NOISY WORDS:" print
+ noisy-words 80 head noise.
+ nl
+ "NOISY VOCABS:" print
+ noisy-vocabs 80 head noise. ;
MAIN: noise-report
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index e86cee0c47..a2011d518c 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -24,7 +24,11 @@ SYMBOL: walking-thread
: break ( -- )
continuation callstack over set-continuation-call
- get-walker-thread send-synchronous {
+USE: prettyprint USE: io.streams.c
+ "BREAK" show
+ get-walker-thread dup unparse-short show "SS" show send-synchronous
+USE: prettyprint USE: io.streams.c
+ unparse-short show {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
@@ -146,10 +150,18 @@ SYMBOL: +detached+
walker-status tget set-model ;
: unassociate-thread ( -- )
- walker-thread walking-thread tget thread-variables delete-at
- [ ] walking-thread tget set-thread-exit-handler ;
+ walker-thread walking-thread tget thread-variables at self eq? [
+ walker-thread walking-thread tget thread-variables delete-at
+ [ ] walking-thread tget set-thread-exit-handler
+ ] [
+USE: io
+ global [ "OOPS" print flush ] bind
+ ] if ;
+
+: xshow self unparse-short append show ;
: detach-msg ( -- )
+ "DETACH" xshow
+detached+ set-status
unassociate-thread ;
@@ -195,6 +207,7 @@ SYMBOL: +detached+
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
[ status +suspended+ eq? ] [
+ "SUSPENDED" xshow
dup walker-history tget push
dup walker-continuation tget set-model
[
@@ -222,6 +235,7 @@ SYMBOL: +detached+
: walker-loop ( -- )
+running+ set-status
[ status +detached+ eq? not ] [
+ "RUNNING" xshow
[
{
{ detach [ detach-msg f ] }
@@ -241,7 +255,9 @@ SYMBOL: +detached+
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] while ;
+ ] [ ] while USE: dlists USE: concurrency.mailboxes
+ "EXIT" xshow
+ my-mailbox mailbox-data dlist-empty? [ "Crap" print flush ] unless ;
: associate-thread ( walker -- )
walker-thread tset
From 7bd91f68c9c8d04d9ef8df01ea7948e5a63e22a9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 17 Mar 2008 05:08:47 -0500
Subject: [PATCH 064/197] Fix walker
---
extra/tools/walker/walker.factor | 24 ++++--------------------
1 file changed, 4 insertions(+), 20 deletions(-)
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index a2011d518c..e86cee0c47 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -24,11 +24,7 @@ SYMBOL: walking-thread
: break ( -- )
continuation callstack over set-continuation-call
-USE: prettyprint USE: io.streams.c
- "BREAK" show
- get-walker-thread dup unparse-short show "SS" show send-synchronous
-USE: prettyprint USE: io.streams.c
- unparse-short show {
+ get-walker-thread send-synchronous {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
@@ -150,18 +146,10 @@ SYMBOL: +detached+
walker-status tget set-model ;
: unassociate-thread ( -- )
- walker-thread walking-thread tget thread-variables at self eq? [
- walker-thread walking-thread tget thread-variables delete-at
- [ ] walking-thread tget set-thread-exit-handler
- ] [
-USE: io
- global [ "OOPS" print flush ] bind
- ] if ;
-
-: xshow self unparse-short append show ;
+ walker-thread walking-thread tget thread-variables delete-at
+ [ ] walking-thread tget set-thread-exit-handler ;
: detach-msg ( -- )
- "DETACH" xshow
+detached+ set-status
unassociate-thread ;
@@ -207,7 +195,6 @@ USE: io
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
[ status +suspended+ eq? ] [
- "SUSPENDED" xshow
dup walker-history tget push
dup walker-continuation tget set-model
[
@@ -235,7 +222,6 @@ USE: io
: walker-loop ( -- )
+running+ set-status
[ status +detached+ eq? not ] [
- "RUNNING" xshow
[
{
{ detach [ detach-msg f ] }
@@ -255,9 +241,7 @@ USE: io
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] while USE: dlists USE: concurrency.mailboxes
- "EXIT" xshow
- my-mailbox mailbox-data dlist-empty? [ "Crap" print flush ] unless ;
+ ] [ ] while ;
: associate-thread ( walker -- )
walker-thread tset
From 86221d57f362b344bf4dcab9c69e7e4ae28d1873 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 17 Mar 2008 09:03:24 -0500
Subject: [PATCH 065/197] fix cairo-demo my commit did more than fix a
using..oops
---
extra/cairo-demo/cairo-demo.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor
index ab8858efb3..29fb99a301 100644
--- a/extra/cairo-demo/cairo-demo.factor
+++ b/extra/cairo-demo/cairo-demo.factor
@@ -22,11 +22,11 @@ IN: cairo-demo
TUPLE: cairo-gadget image-array cairo-t ;
-! M: cairo-gadget draw-gadget* ( gadget -- )
-! 0 0 glRasterPos2i
-! 1.0 -1.0 glPixelZoom
-! >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
-! cairo-gadget-image-array glDrawPixels ;
+M: cairo-gadget draw-gadget* ( gadget -- )
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+ cairo-gadget-image-array glDrawPixels ;
: create-surface ( gadget -- cairo_surface_t )
make-image-array
@@ -60,8 +60,8 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
M: cairo-gadget graft* ( gadget -- )
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
-! M: cairo-gadget ungraft* ( gadget -- )
-! cairo-gadget-cairo-t cairo_destroy ;
+M: cairo-gadget ungraft* ( gadget -- )
+ cairo-gadget-cairo-t cairo_destroy ;
: <cairo-gadget> ( -- gadget )
cairo-gadget construct-gadget ;
From 880a3a2af41ebbec3274eccf3c840e25457de3b8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 17 Mar 2008 14:14:04 -0500
Subject: [PATCH 066/197] before major refactoring
---
extra/db/sqlite/lib/lib.factor | 1 +
extra/db/sqlite/sqlite.factor | 2 ++
extra/db/tuples/tuples-tests.factor | 42 ++++++++++++++++++++---------
extra/db/types/types.factor | 2 --
4 files changed, 33 insertions(+), 14 deletions(-)
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index 0e512ad018..f81d7de4b8 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -121,6 +121,7 @@ IN: db.sqlite.lib
dup array? [ first ] when
{
{ +native-id+ [ sqlite3_column_int64 ] }
+ { +random-id+ [ sqlite3_column_int64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }
{ DOUBLE [ sqlite3_column_double ] }
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 1b594d6fa4..bca904279b 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -190,6 +190,7 @@ M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
+ { +random-id+ "primary key" }
! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
@@ -209,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- str' )
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
+ { +random-id+ "integer primary key" }
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 2dbf6d1008..6b61981119 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -196,13 +196,6 @@ TUPLE: annotation n paste-id summary author mode contents ;
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
-[ native-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-tuples ] test-sqlite
-[ native-person-schema test-tuples ] test-postgresql
-[ assigned-person-schema test-tuples ] test-postgresql
-[ assigned-person-schema test-repeated-insert ] test-sqlite
-[ assigned-person-schema test-repeated-insert ] test-postgresql
-
TUPLE: serialize-me id data ;
: test-serialize ( -- )
@@ -247,8 +240,33 @@ TUPLE: exam id name score ;
! [ test-ranges ] test-sqlite
-\ insert-tuple must-infer
-\ update-tuple must-infer
-\ delete-tuple must-infer
-\ select-tuple must-infer
-\ define-persistent must-infer
+TUPLE: secret n message ;
+C: <secret> secret
+
+: test-random-id
+ secret "SECRET"
+ {
+ { "n" "ID" +random-id+ }
+ { "message" "MESSAGE" TEXT }
+ } define-persistent
+
+ [ ] [ secret ensure-table ] unit-test
+ [ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
+ [ ] [ T{ secret } select-tuples ] unit-test
+ ;
+
+
+
+! [ test-random-id ] test-sqlite
+ [ native-person-schema test-tuples ] test-sqlite
+ [ assigned-person-schema test-tuples ] test-sqlite
+! [ assigned-person-schema test-repeated-insert ] test-sqlite
+! [ native-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-repeated-insert ] test-postgresql
+
+! \ insert-tuple must-infer
+! \ update-tuple must-infer
+! \ delete-tuple must-infer
+! \ select-tuple must-infer
+! \ define-persistent must-infer
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 532c097957..a0414f334d 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -15,14 +15,12 @@ HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
-
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SINGLETON: +random-id+
UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
-! +native-id+ +assigned-id+ +random-assigned-id+
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
From 296a20767fae2ac3417cb2aff28315252f8173ed Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 01:26:09 -0500
Subject: [PATCH 067/197] Fix a race condition
---
extra/tools/walker/debug/debug.factor | 20 +++----
extra/tools/walker/walker.factor | 75 ++++++++++++---------------
extra/ui/tools/walker/walker.factor | 41 +++++++++------
3 files changed, 69 insertions(+), 67 deletions(-)
diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor
index c8c0ff28a6..1fded308b4 100755
--- a/extra/tools/walker/debug/debug.factor
+++ b/extra/tools/walker/debug/debug.factor
@@ -2,17 +2,19 @@
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals continuations
-threads namespaces namespaces.private ;
+threads namespaces namespaces.private assocs ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
- [let | p [ <promise> ]
- s [ f <model> ]
- c [ f <model> ] |
+ [let | p [ <promise> ] |
[
H{ } clone >n
- [ s c start-walker-thread p fulfill ] new-walker-hook set
- [ drop ] show-walker-hook set
+
+ [
+ p promise-fulfilled?
+ [ drop ] [ p fulfill ] if
+ 2drop
+ ] show-walker-hook set
break
@@ -23,9 +25,7 @@ IN: tools.walker.debug
p ?promise
send-synchronous drop
- detach
p ?promise
- send-synchronous drop
-
- c model-value continuation-data
+ thread-variables walker-continuation swap at
+ model-value continuation-data
] ;
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index e86cee0c47..610d3db0a3 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -3,33 +3,51 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models ;
+sequences.private assocs models combinators.cleave ;
IN: tools.walker
-SYMBOL: new-walker-hook ! ( -- )
-SYMBOL: show-walker-hook ! ( thread -- )
+SYMBOL: show-walker-hook ! ( status continuation thread -- )
-! Thread local
+! Thread local in thread being walked
SYMBOL: walker-thread
-SYMBOL: walking-thread
-: get-walker-thread ( -- thread )
+! Thread local in walker thread
+SYMBOL: walking-thread
+SYMBOL: walker-status
+SYMBOL: walker-continuation
+SYMBOL: walker-history
+
+DEFER: start-walker-thread
+
+: get-walker-thread ( -- status continuation thread )
walker-thread tget [
- dup show-walker-hook get call
+ [ thread-variables walker-status swap at ]
+ [ thread-variables walker-continuation swap at ]
+ [ ] tri
] [
- new-walker-hook get call
- walker-thread tget
+ f <model>
+ f <model>
+ 2dup start-walker-thread
] if* ;
-: break ( -- )
- continuation callstack over set-continuation-call
+USING: io.streams.c prettyprint ;
- get-walker-thread send-synchronous {
+: show-walker ( -- thread )
+ get-walker-thread
+ [ show-walker-hook get call ] keep ;
+
+: after-break ( object -- )
+ {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
} cond ;
+: break ( -- )
+ continuation callstack over set-continuation-call
+ show-walker send-synchronous
+ after-break ;
+
\ break t "break?" set-word-prop
: walk ( quot -- quot' )
@@ -71,15 +89,9 @@ SYMBOL: detach
SYMBOL: abandon
SYMBOL: call-in
-! Thread locals
-SYMBOL: walker-status
-SYMBOL: walker-continuation
-SYMBOL: walker-history
-
SYMBOL: +running+
SYMBOL: +suspended+
SYMBOL: +stopped+
-SYMBOL: +detached+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
@@ -145,34 +157,20 @@ SYMBOL: +detached+
: set-status ( symbol -- )
walker-status tget set-model ;
-: unassociate-thread ( -- )
- walker-thread walking-thread tget thread-variables delete-at
- [ ] walking-thread tget set-thread-exit-handler ;
-
-: detach-msg ( -- )
- +detached+ set-status
- unassociate-thread ;
-
: keep-running ( -- )
+running+ set-status ;
: walker-stopped ( -- )
+stopped+ set-status
- [ status +stopped+ eq? ] [
- [
- {
- { detach [ detach-msg ] }
- [ drop ]
- } case f
- ] handle-synchronous
- ] [ ] while ;
+ [ status +stopped+ eq? ]
+ [ [ drop f ] handle-synchronous ]
+ [ ] while ;
: step-into-all-loop ( -- )
+running+ set-status
[ status +running+ eq? ] [
[
{
- { detach [ detach-msg f ] }
{ step [ f ] }
{ step-out [ f ] }
{ step-into [ f ] }
@@ -201,10 +199,6 @@ SYMBOL: +detached+
{
! These are sent by the walker tool. We reply
! and keep cycling.
- { detach [ detach-msg ] }
- ! These change the state of the thread being
- ! interpreted, so we modify the continuation and
- ! output f.
{ step [ step-msg keep-running ] }
{ step-out [ step-out-msg keep-running ] }
{ step-into [ step-into-msg keep-running ] }
@@ -221,10 +215,9 @@ SYMBOL: +detached+
: walker-loop ( -- )
+running+ set-status
- [ status +detached+ eq? not ] [
+ [ status +stopped+ eq? not ] [
[
{
- { detach [ detach-msg f ] }
! ignore these commands while the thread is
! running
{ step [ f ] }
diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor
index bc038cd244..a9fe38a14c 100755
--- a/extra/ui/tools/walker/walker.factor
+++ b/extra/ui/tools/walker/walker.factor
@@ -4,14 +4,18 @@ USING: kernel concurrency.messaging inspector ui.tools.listener
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
-namespaces tools.walker assocs ;
+namespaces tools.walker assocs combinators combinators.cleave ;
IN: ui.tools.walker
-TUPLE: walker-gadget status continuation thread traceback ;
+TUPLE: walker-gadget
+status continuation thread
+traceback
+closing? ;
: walker-command ( walker msg -- )
- over walker-gadget-thread thread-registered?
- [ swap walker-gadget-thread send-synchronous drop ]
+ swap
+ dup walker-gadget-thread thread-registered?
+ [ walker-gadget-thread send-synchronous drop ]
[ 2drop ] if ;
: com-step ( walker -- ) step walker-command ;
@@ -27,7 +31,9 @@ TUPLE: walker-gadget status continuation thread traceback ;
: com-abandon ( walker -- ) abandon walker-command ;
M: walker-gadget ungraft*
- dup delegate ungraft* detach walker-command ;
+ [ t swap set-walker-gadget-closing? ]
+ [ com-continue ]
+ [ delegate ungraft* ] tri ;
M: walker-gadget focusable-child*
walker-gadget-traceback ;
@@ -41,7 +47,6 @@ M: walker-gadget focusable-child*
{ +stopped+ "Stopped" }
{ +suspended+ "Suspended" }
{ +running+ "Running" }
- { +detached+ "Detached" }
} at %
")" %
drop
@@ -51,7 +56,7 @@ M: walker-gadget focusable-child*
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
- over <traceback-gadget> walker-gadget construct-boa [
+ over <traceback-gadget> f walker-gadget construct-boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
@@ -72,16 +77,20 @@ walker-gadget "toolbar" f {
{ T{ key-down f f "F1" } walker-help }
} define-command-map
-: walker-window ( -- )
- f <model> f <model> 2dup start-walker-thread
- [ <walker-gadget> ] keep thread-name open-status-window ;
+: walker-for-thread? ( thread gadget -- ? )
+ {
+ { [ dup walker-gadget? not ] [ 2drop f ] }
+ { [ dup walker-gadget-closing? ] [ 2drop f ] }
+ { [ t ] [ walker-gadget-thread eq? ] }
+ } cond ;
-[ [ walker-window ] with-ui ] new-walker-hook set-global
+: find-walker-window ( thread -- world/f )
+ [ swap walker-for-thread? ] curry find-window ;
+
+: walker-window ( status continuation thread -- )
+ [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
[
- [
- >r dup walker-gadget?
- [ walker-gadget-thread r> eq? ]
- [ r> 2drop f ] if
- ] curry find-window raise-window
+ dup find-walker-window dup
+ [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
] show-walker-hook set-global
From 6e7556242b32497456f3e44478452d916d16eeb9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 01:26:30 -0500
Subject: [PATCH 068/197] Comment out compilation unit stuff for now
---
extra/serialize/serialize.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index 86fadf55bf..36d5e40b77 100755
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -316,10 +316,10 @@ SYMBOL: deserialized
deserialize* [ "End of stream" throw ] unless ;
: deserialize ( -- obj )
- [
- V{ } clone deserialized
- [ (deserialize) ] with-variable
- ] with-compilation-unit ;
+ ! [
+ V{ } clone deserialized
+ [ (deserialize) ] with-variable ;
+ ! ] with-compilation-unit ;
: serialize ( obj -- )
H{ } clone serialized [ (serialize) ] with-variable ;
From 65c74d8404bd6bcd61fb0c29d911b39c2c813d15 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 02:37:31 -0500
Subject: [PATCH 069/197] Fix macosx/ppc bootstrap
---
core/parser/parser.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index c955817ab9..cf31c16662 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -292,7 +292,7 @@ M: no-word summary
create-method f set-word dup save-location ;
: CREATE-METHOD ( -- method )
- scan-word scan-word create-method-in ;
+ scan-word bootstrap-word scan-word create-method-in ;
TUPLE: staging-violation word ;
From 4b2368e99f77bd10566ec5c3dabfc770f708a87e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 03:27:14 -0500
Subject: [PATCH 070/197] Fix io.unix.launcher unit test
---
extra/io/unix/launcher/launcher-tests.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
mode change 100644 => 100755 extra/io/unix/launcher/launcher-tests.factor
diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor
old mode 100644
new mode 100755
index aa54d3ec94..6fa8c913aa
--- a/extra/io/unix/launcher/launcher-tests.factor
+++ b/extra/io/unix/launcher/launcher-tests.factor
@@ -34,7 +34,7 @@ accessors kernel sequences ;
ascii <process-stream> contents
] unit-test
-[ "" ] [
+[ f ] [
<process>
"cat"
"launcher-test-1" temp-file
@@ -55,7 +55,7 @@ accessors kernel sequences ;
try-process
] unit-test
-[ "" ] [
+[ f ] [
"cat"
"launcher-test-1" temp-file
2array
From b362175d436099b4214e88a861eb15e721059d86 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Tue, 18 Mar 2008 17:01:14 -0400
Subject: [PATCH 071/197] Initial optimization of encodings
---
core/io/encodings/encodings-docs.factor | 30 +++++------
core/io/encodings/encodings.factor | 19 ++++---
core/io/encodings/utf8/utf8.factor | 2 +-
core/io/streams/byte-array/byte-array.factor | 4 +-
core/io/streams/string/string.factor | 5 +-
extra/io/encodings/ascii/ascii.factor | 8 +--
extra/io/encodings/utf16/utf16.factor | 56 +++++++++-----------
extra/io/unix/launcher/launcher-tests.factor | 8 +--
8 files changed, 65 insertions(+), 67 deletions(-)
diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor
index e5e71b05f0..548d2cd7fc 100644
--- a/core/io/encodings/encodings-docs.factor
+++ b/core/io/encodings/encodings-docs.factor
@@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
-{ $subsection decode-step }
-{ $subsection init-decoder }
-{ $subsection stream-write-encoded } ;
+{ $subsection decode-char }
+{ $subsection encode-char }
+"The following methods are optional:"
+{ $subsection <encoder> }
+{ $subsection <decoder> } ;
-HELP: decode-step ( buf char encoding -- )
-{ $values { "buf" "A string buffer which characters can be pushed to" }
- { "char" "An octet which is read from a stream" }
+HELP: decode-char ( stream encoding -- char/f )
+{ $values { "stream" "an underlying input stream" }
{ "encoding" "An encoding descriptor tuple" } }
-{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
+{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
-HELP: stream-write-encoded ( string stream encoding -- )
-{ $values { "string" "a string" }
- { "stream" "an output stream" }
+HELP: encode-char ( char stream encoding -- )
+{ $values { "char" "a character" }
+ { "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }
-{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
+{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
-HELP: init-decoder ( stream encoding -- encoding )
-{ $values { "stream" "an input stream" }
- { "encoding" "an encoding descriptor" } }
-{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
-
-{ init-decoder decode-step stream-write-encoded } related-words
+{ encode-char decode-char } related-words
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index b7c71d5527..4cd43ef455 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -61,25 +61,28 @@ M: tuple <decoder> f decoder construct-boa ;
] when nip ;
: read-loop ( n stream -- string )
- over 0 <string> [
+ SBUF" " clone [
[
- >r stream-read1 dup
- [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
- ] 2curry find-integer
- ] keep swap [ head ] when* ;
+ >r nip stream-read1 dup
+ [ r> push f ] [ r> 2drop t ] if
+ ] 2curry find-integer drop
+ ] keep "" like f like ;
M: decoder stream-read
tuck read-loop fix-read ;
+M: decoder stream-read-partial stream-read ;
+
: (read-until) ( buf quot -- string/f sep/f )
- ! quot: -- char keep-going?
+ ! quot: -- char stop?
dup call
[ >r drop "" like r> ]
[ pick push (read-until) ] if ; inline
M: decoder stream-read-until
SBUF" " clone -rot >decoder<
- [ decode-char dup rot memq? ] 3curry (read-until) ;
+ [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
+ (read-until) ;
: fix-read1 ( stream char -- char )
over decoder-cr [
@@ -118,6 +121,8 @@ M: encoder stream-write
M: encoder dispose encoder-stream dispose ;
+M: encoder stream-flush encoder-stream stream-flush ;
+
INSTANCE: encoder plain-writer
! Rebinding duplex streams which have not read anything yet
diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor
index 02b10c45a5..e98860f25d 100644
--- a/core/io/encodings/utf8/utf8.factor
+++ b/core/io/encodings/utf8/utf8.factor
@@ -15,7 +15,7 @@ TUPLE: utf8 ;
: append-nums ( stream byte -- stream char )
over stream-read1 dup starts-2?
- [ 6 shift swap BIN: 111111 bitand bitor ]
+ [ swap 6 shift swap BIN: 111111 bitand bitor ]
[ 2drop replacement-char ] if ;
: double ( stream byte -- stream char )
diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor
index d5ca8eac68..2a8441ff23 100644
--- a/core/io/streams/byte-array/byte-array.factor
+++ b/core/io/streams/byte-array/byte-array.factor
@@ -1,5 +1,5 @@
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces ;
+sequences io namespaces io.encodings.private ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
@@ -7,7 +7,7 @@ IN: io.streams.byte-array
: with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream*
- >byte-array ; inline
+ dup encoder? [ encoder-stream ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoder> ;
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index 33404292a9..b7ff37a971 100755
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -49,8 +49,11 @@ M: growable stream-read
M: growable stream-read-partial
stream-read ;
+TUPLE: null ;
+M: null decode-char drop stream-read1 ;
+
: <string-reader> ( str -- stream )
- >sbuf dup reverse-here f <decoder> ;
+ >sbuf dup reverse-here null <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline
diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor
index 16d87ef39c..d3fe51f28d 100644
--- a/extra/io/encodings/ascii/ascii.factor
+++ b/extra/io/encodings/ascii/ascii.factor
@@ -1,14 +1,16 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math ;
+USING: io io.encodings kernel math io.encodings.private ;
IN: io.encodings.ascii
<PRIVATE
: encode-if< ( char stream encoding max -- )
- nip pick > [ encode-error ] [ stream-write1 ] if ;
+ nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
: decode-if< ( stream encoding max -- character )
- nip swap stream-read1 tuck > [ drop replacement-character ] unless ;
+ nip swap stream-read1
+ [ tuck > [ drop replacement-char ] unless ]
+ [ drop f ] if* ;
PRIVATE>
TUPLE: ascii ;
diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor
index 7e82935db7..290761ec91 100755
--- a/extra/io/encodings/utf16/utf16.factor
+++ b/extra/io/encodings/utf16/utf16.factor
@@ -1,14 +1,14 @@
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays ;
+io.encodings combinators splitting io byte-arrays inspector ;
IN: io.encodings.utf16
TUPLE: utf16be ;
-TUPLE: utf16le ch state ;
+TUPLE: utf16le ;
-TUPLE: utf16 started? ;
+TUPLE: utf16 ;
<PRIVATE
@@ -21,12 +21,12 @@ TUPLE: utf16 started? ;
over stream-read1 swap append-nums ;
: quad-be ( stream byte -- stream char )
- double-be over stream-read1 dup [
+ double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
over stream-read1 swap append-nums HEX: 10000 +
- ] [ 2drop replacement-char ] if
- ] when ;
+ ] [ 2drop dup stream-read1 drop replacement-char ] if
+ ] when* ;
: ignore ( stream -- stream char )
dup stream-read1 drop replacement-char ;
@@ -38,7 +38,7 @@ TUPLE: utf16 started? ;
[ drop ignore ] if
] [ double-be ] if ;
-M: decode-char
+M: utf16be decode-char
drop dup stream-read1 dup [ begin-utf16be ] when nip ;
! UTF-16LE decoding
@@ -54,59 +54,48 @@ M: decode-char
dup BIN: 100 bitand 0 number=
[ BIN: 11 bitand 8 shift bitor quad-le ]
[ 2drop replacement-char ] if
- ] [ swap append-nums ] if ;
-
-: decode-utf16le-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop double ] }
- { double [ handle-double ] }
- { quad2 [ 10 shift bitor quad3 ] }
- { quad3 [ handle-quad3le ] }
- } case ;
+ ] [ append-nums ] if ;
: begin-utf16le ( stream byte -- stream char )
- over stream-read1 [ double-le ] [ drop replacement-char ] if*
+ over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
-M: decode-char
+M: utf16le decode-char
drop dup stream-read1 dup [ begin-utf16le ] when nip ;
! UTF-16LE/BE encoding
-: encode-first
+: encode-first ( char -- byte1 byte2 )
-10 shift
dup -8 shift BIN: 11011000 bitor
swap HEX: FF bitand ;
-: encode-second
+: encode-second ( char -- byte3 byte4 )
BIN: 1111111111 bitand
dup -8 shift BIN: 11011100 bitor
swap BIN: 11111111 bitand ;
: stream-write2 ( stream char1 char2 -- )
- rot [ stream-write1 ] 2apply ;
+ rot [ stream-write1 ] curry 2apply ;
: char>utf16be ( stream char -- )
dup HEX: FFFF > [
HEX: 10000 -
- dup encode-first stream-write2
+ 2dup encode-first stream-write2
encode-second stream-write2
] [ h>b/b swap stream-write2 ] if ;
M: utf16be encode-char ( char stream encoding -- )
- drop char>utf16be ;
+ drop swap char>utf16be ;
-: char>utf16le ( char -- )
+: char>utf16le ( char stream -- )
dup HEX: FFFF > [
HEX: 10000 -
- dup encode-first swap stream-write2
+ 2dup encode-first swap stream-write2
encode-second swap stream-write2
] [ h>b/b stream-write2 ] if ;
-: stream-write-utf16le ( string stream -- )
- [ [ char>utf16le ] each ] with-stream* ;
-
-M: utf16le stream-write-encoded ( string stream encoding -- )
- drop stream-write-utf16le ;
+M: utf16le encode-char ( char stream encoding -- )
+ drop swap char>utf16le ;
! UTF-16
@@ -118,13 +107,16 @@ M: utf16le stream-write-encoded ( string stream encoding -- )
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
+TUPLE: missing-bom ;
+M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
+
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ decode-error ] if
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
] if ;
M: utf16 <decoder> ( stream utf16 -- decoder )
- 2 rot stream-read bom>le/be <decoder> ;
+ drop 2 over stream-read bom>le/be <decoder> ;
M: utf16 <encoder> ( stream utf16 -- encoder )
drop bom-le over stream-write utf16le <encoder> ;
diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor
index aa54d3ec94..5370817d2f 100644
--- a/extra/io/unix/launcher/launcher-tests.factor
+++ b/extra/io/unix/launcher/launcher-tests.factor
@@ -1,6 +1,6 @@
IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.ascii io.encodings.latin1
+continuations math io.encodings.binary io.encodings.ascii
accessors kernel sequences ;
[ ] [
@@ -64,7 +64,7 @@ accessors kernel sequences ;
[ ] [
2 [
- "launcher-test-1" temp-file ascii <file-appender> [
+ "launcher-test-1" temp-file binary <file-appender> [
<process>
swap >>stdout
"echo Hello" >>command
@@ -84,7 +84,7 @@ accessors kernel sequences ;
<process>
"env" >>command
{ { "A" "B" } } >>environment
- latin1 <process-stream> lines
+ ascii <process-stream> lines
"A=B" swap member?
] unit-test
@@ -93,5 +93,5 @@ accessors kernel sequences ;
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
- latin1 <process-stream> lines
+ ascii <process-stream> lines
] unit-test
From f31c521c47d3274e50dce37bab663a4501015b84 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 17:46:25 -0500
Subject: [PATCH 072/197] Assorted bug fixes
---
core/alien/alien-tests.factor | 10 +++++++---
core/classes/classes-tests.factor | 2 ++
core/inference/class/class-tests.factor | 4 +++-
core/parser/parser-tests.factor | 4 +++-
core/parser/parser.factor | 10 +++++++++-
extra/fry/fry-docs.factor | 2 +-
extra/help/stylesheet/stylesheet.factor | 1 +
vm/alien.c | 6 +++---
8 files changed, 29 insertions(+), 10 deletions(-)
diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor
index 5f7b9fff21..28a1e98710 100755
--- a/core/alien/alien-tests.factor
+++ b/core/alien/alien-tests.factor
@@ -1,7 +1,7 @@
IN: alien.tests
-USING: alien alien.accessors byte-arrays arrays kernel
-kernel.private namespaces tools.test sequences libc math system
-prettyprint layouts ;
+USING: alien alien.accessors alien.syntax byte-arrays arrays
+kernel kernel.private namespaces tools.test sequences libc math
+system prettyprint layouts ;
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
@@ -68,3 +68,7 @@ cell 8 = [
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
+
+[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
+
+[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index dbc1bcace2..7d43ee905a 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -28,6 +28,8 @@ TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
+[ null ] [ vector virtual-sequence class-and ] unit-test
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 17197db667..e7fcbfcb08 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -294,4 +294,6 @@ cell-bits 32 = [
\ >= inlined?
] unit-test
-
+[ t ] [
+ [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
+] unit-test
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index a69e28ab97..050bd735c0 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -1,7 +1,7 @@
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units debugger ;
+sorting tuples compiler.units debugger vocabs.loader ;
IN: parser.tests
[
@@ -447,3 +447,5 @@ must-fail-with
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
] times
+
+[ ] [ "parser" reload ] unit-test
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index cf31c16662..fd93479283 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -478,7 +478,15 @@ SYMBOL: interactive-vocabs
: smudged-usage ( -- usages referenced removed )
removed-definitions filter-moved keys [
outside-usages
- [ empty? swap pathname? or not ] assoc-subset
+ [
+ empty? [ drop f ] [
+ {
+ { [ dup pathname? ] [ f ] }
+ { [ dup method-body? ] [ f ] }
+ { [ t ] [ t ] }
+ } cond nip
+ ] if
+ ] assoc-subset
dup values concat prune swap keys
] keep ;
diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor
index 31b544d488..739e7d012c 100755
--- a/extra/fry/fry-docs.factor
+++ b/extra/fry/fry-docs.factor
@@ -46,7 +46,7 @@ $nl
}
"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"
{ $code
- "{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map"
+ "{ 8 13 14 27 } [ even? ] 5 '[ @ dup , ? ] map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
diff --git a/extra/help/stylesheet/stylesheet.factor b/extra/help/stylesheet/stylesheet.factor
index 945d9a4ce1..68810e2369 100755
--- a/extra/help/stylesheet/stylesheet.factor
+++ b/extra/help/stylesheet/stylesheet.factor
@@ -82,6 +82,7 @@ H{
{ page-color { 0.95 0.95 0.95 1 } }
{ border-color { 1 0 0 1 } }
{ border-width 5 }
+ { wrap-margin 500 }
} warning-style set-global
SYMBOL: table-content-style
diff --git a/vm/alien.c b/vm/alien.c
index 26d9464700..a7dd654cf2 100755
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -197,15 +197,15 @@ DEFINE_PRIMITIVE(dlsym)
F_DLL *d;
if(dll == F)
- d = NULL;
+ box_alien(ffi_dlsym(NULL,sym));
else
{
d = untag_dll(dll);
if(d->dll == NULL)
dpush(F);
+ else
+ box_alien(ffi_dlsym(d,sym));
}
-
- box_alien(ffi_dlsym(d,sym));
}
/* close a native library handle */
From 290883f0e4e33ed138fc6cb42b8dddbb0a4670fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 18:02:24 -0500
Subject: [PATCH 073/197] Fix DLL"
---
core/alien/syntax/syntax.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index b81a91efcb..3bd68bfde7 100755
--- a/core/alien/syntax/syntax.factor
+++ b/core/alien/syntax/syntax.factor
@@ -32,7 +32,7 @@ PRIVATE>
>r >r swapd roll indirect-quot r> r>
-rot define-declared ;
-: DLL" skip-blank parse-string dlopen parsed ; parsing
+: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing
From cb4974aa344083dd04ac0345f4837ddc9bc66762 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 18 Mar 2008 18:17:25 -0500
Subject: [PATCH 074/197] Fix fs-events issue
---
extra/core-foundation/fsevents/fsevents.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor
index 41d2844811..55f2462061 100644
--- a/extra/core-foundation/fsevents/fsevents.factor
+++ b/extra/core-foundation/fsevents/fsevents.factor
@@ -150,7 +150,8 @@ SYMBOL: event-stream-callbacks
: event-stream-counter \ event-stream-counter counter ;
[
- H{ } clone event-stream-callbacks set-global
+ event-stream-callbacks global
+ [ [ drop expired? not ] assoc-subset ] change-at
1 \ event-stream-counter set-global
] "core-foundation" add-init-hook
From a855846b764dc5c31d1197b8305ced25fab01c74 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 19:43:36 -0500
Subject: [PATCH 075/197] cairo dll update
---
extra/cairo/ffi/ffi.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor
index d7aa90c464..76ce27975b 100644
--- a/extra/cairo/ffi/ffi.factor
+++ b/extra/cairo/ffi/ffi.factor
@@ -13,7 +13,7 @@ USING: alien alien.syntax combinators system ;
IN: cairo.ffi
<< "cairo" {
- { [ win32? ] [ "cairo.dll" ] }
+ { [ win32? ] [ "libcairo-2.dll" ] }
! { [ macosx? ] [ "libcairo.dylib" ] }
{ [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
{ [ unix? ] [ "libcairo.so.2" ] }
From 55a8c991ad329bdc53edfcd03722016474be9ec0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 18 Mar 2008 18:59:37 -0500
Subject: [PATCH 076/197] fix gmt-offset on windows
---
extra/calendar/windows/windows.factor | 27 +++++++++++++--------------
1 file changed, 13 insertions(+), 14 deletions(-)
diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor
index 1609b9f260..6986902ff1 100755
--- a/extra/calendar/windows/windows.factor
+++ b/extra/calendar/windows/windows.factor
@@ -1,22 +1,21 @@
USING: calendar.backend namespaces alien.c-types
-windows windows.kernel32 kernel math ;
+windows windows.kernel32 kernel math combinators.cleave
+combinators ;
IN: calendar.windows
TUPLE: windows-calendar ;
T{ windows-calendar } calendar-backend set-global
-: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
-
M: windows-calendar gmt-offset ( -- hours minutes seconds )
- 0 0 0 ;
- ! "TIME_ZONE_INFORMATION" <c-object>
- ! dup GetTimeZoneInformation {
- ! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
- ! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
- ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
- ! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
- ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
- ! [ TIME_ZONE_INFORMATION-DaylightBias ] bi
- ! ] }
- ! } cond ;
+ "TIME_ZONE_INFORMATION" <c-object>
+ dup GetTimeZoneInformation {
+ { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
+ { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
+ drop TIME_ZONE_INFORMATION-Bias ] }
+ { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
+ drop
+ [ TIME_ZONE_INFORMATION-Bias ]
+ [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
+ ] }
+ } cond neg 60 /mod 0 ;
From 4ec88d6bc688aefa3735ebedddc7158b92b043d3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 20:24:29 -0500
Subject: [PATCH 077/197] Fix tests typo
---
core/inference/class/class-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index e7fcbfcb08..67b8616c61 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
-system layouts ;
+system layouts vectors ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
From 23dd1f33105746ad63c76d8b954fa0663bc4591b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 20:24:39 -0500
Subject: [PATCH 078/197] Fix usage typo
---
core/io/streams/c/c-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
mode change 100644 => 100755 core/io/streams/c/c-docs.factor
diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor
old mode 100644
new mode 100755
index 5d9c7b1a53..6c640bbdeb
--- a/core/io/streams/c/c-docs.factor
+++ b/core/io/streams/c/c-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.files threads
-strings byte-arrays io.streams.lines io.streams.plain ;
+strings byte-arrays io.streams.plain ;
IN: io.streams.c
ARTICLE: "io.streams.c" "ANSI C streams"
From da7f10804afc99d03aeda9341de0df3e688d0b79 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 20:27:09 -0500
Subject: [PATCH 079/197] Refactor vocab loader
---
core/vocabs/loader/loader-tests.factor | 9 ++++
core/vocabs/loader/loader.factor | 59 ++++++++++++++------------
core/vocabs/vocabs.factor | 20 +++++----
extra/bootstrap/help/help.factor | 7 ++-
extra/help/markup/markup.factor | 3 +-
extra/tools/vocabs/vocabs.factor | 8 ++--
6 files changed, 60 insertions(+), 46 deletions(-)
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 514e45f10f..015f54540d 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -78,6 +78,8 @@ IN: vocabs.loader.tests
] with-compilation-unit
] unit-test
+[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
+
[ ] [
[
"vocabs.loader.test.b" vocab-files
@@ -118,6 +120,13 @@ IN: vocabs.loader.tests
[ { "resource:core/kernel/kernel.factor" 1 } ]
[ "kernel" vocab where ] unit-test
+[ ] [
+ [
+ "vocabs.loader.test.c" forget-vocab
+ "vocabs.loader.test.d" forget-vocab
+ ] with-compilation-unit
+] unit-test
+
[ t ] [
[ "vocabs.loader.test.d" require ] [ :1 ] recover
"vocabs.loader.test.d" vocab-source-loaded?
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index fa9ff5b504..96193ef664 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -43,7 +43,7 @@ V{
vocab-roots get swap [ vocab-dir? ] curry find nip ;
M: string vocab-root
- dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
+ vocab dup [ vocab-root ] when ;
M: vocab-link vocab-root
vocab-link-root ;
@@ -66,24 +66,22 @@ SYMBOL: load-help?
: load-docs ( vocab -- )
load-help? get [
[ docs-weren't-loaded ] keep
- [ vocab-docs-path ?run-file ] keep
+ [ vocab-docs-path [ ?run-file ] when* ] keep
docs-were-loaded
] [ drop ] if ;
-: create-vocab-with-root ( vocab-link -- vocab )
- dup vocab-name create-vocab
- swap vocab-root over set-vocab-root ;
+: create-vocab-with-root ( name root -- vocab )
+ swap create-vocab [ set-vocab-root ] keep ;
+
+: update-root ( vocab -- )
+ dup vocab-root
+ [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
: reload ( name -- )
[
- f >vocab-link
- dup vocab-root [
- dup vocab-source-path resource-exists? [
- create-vocab-with-root
- dup load-source
- load-docs
- ] [ no-vocab ] if
- ] [ no-vocab ] if
+ dup vocab [
+ dup update-root dup load-source load-docs
+ ] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
@@ -100,33 +98,38 @@ SYMBOL: load-help?
SYMBOL: blacklist
-GENERIC: (load-vocab) ( name -- vocab )
-
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
+GENERIC: (load-vocab) ( name -- )
+
M: vocab (load-vocab)
- [
- dup vocab-root [
+ dup update-root
+
+ dup vocab-root [
+ [
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
- ] when
- ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
+ ] [ [ swap add-to-blacklist ] keep rethrow ] recover
+ ] when drop ;
M: string (load-vocab)
- [ ".private" ?tail drop reload ] keep vocab ;
+ ! ".private" ?tail drop
+ dup find-vocab-root >vocab-link (load-vocab) ;
M: vocab-link (load-vocab)
- vocab-name (load-vocab) ;
+ dup vocab-name swap vocab-root dup
+ [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
[
- dup vocab-name blacklist get at* [
- rethrow
- ] [
- drop
- [ dup vocab swap or (load-vocab) ] with-compiler-errors
- ] if
-
+ [
+ dup vocab-name blacklist get at* [
+ rethrow
+ ] [
+ drop
+ [ (load-vocab) ] with-compiler-errors
+ ] if
+ ] with-compiler-errors
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 1a3fecc3fb..9d281c864b 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -15,8 +15,8 @@ source-loaded? docs-loaded? ;
M: vocab equal? 2drop f ;
: <vocab> ( name -- vocab )
- H{ } clone t
- { set-vocab-name set-vocab-words set-vocab-source-loaded? }
+ H{ } clone
+ { set-vocab-name set-vocab-words }
\ vocab construct ;
GENERIC: vocab ( vocab-spec -- vocab )
@@ -60,9 +60,16 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
-SYMBOL: load-vocab-hook
+TUPLE: no-vocab name ;
-: load-vocab ( name -- vocab ) load-vocab-hook get call ;
+: no-vocab ( name -- * )
+ vocab-name \ no-vocab construct-boa throw ;
+
+SYMBOL: load-vocab-hook ! ( name -- )
+
+: load-vocab ( name -- vocab )
+ dup load-vocab-hook get call
+ dup vocab [ ] [ no-vocab ] ?if ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
@@ -115,8 +122,3 @@ UNION: vocab-spec vocab vocab-link ;
vocab-name dictionary get delete-at ;
M: vocab-spec forget* forget-vocab ;
-
-TUPLE: no-vocab name ;
-
-: no-vocab ( name -- * )
- vocab-name \ no-vocab construct-boa throw ;
diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor
index 1680278fad..4326fcf61b 100755
--- a/extra/bootstrap/help/help.factor
+++ b/extra/bootstrap/help/help.factor
@@ -9,11 +9,10 @@ IN: bootstrap.help
t load-help? set-global
- [ vocab ] load-vocab-hook [
+ [ drop ] load-vocab-hook [
vocabs
- [ vocab-root ] subset
- [ vocab-source-loaded? ] subset
- [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
+ [ vocab-docs-loaded? not ] subset
+ [ load-docs ] each
] with-variable ;
load-help
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 710671857e..7cfe384bde 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -158,7 +158,8 @@ M: f print-element drop ;
: $subsection ( element -- )
[ first ($long-link) ] ($subsection) ;
-: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
+: ($vocab-link) ( text vocab -- )
+ dup vocab-root >vocab-link write-link ;
: $vocab-subsection ( element -- )
[
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 675a2e1d6e..82c411cbfb 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -19,16 +19,16 @@ IN: tools.vocabs
] [ drop ] if ;
: vocab-tests ( vocab -- tests )
- dup vocab-root [
+ dup vocab-root dup [
[
- f >vocab-link dup
+ >vocab-link dup
vocab-tests-file,
vocab-tests-dir,
] { } make
- ] [ drop f ] if ;
+ ] [ 2drop f ] if ;
: vocab-files ( vocab -- seq )
- f >vocab-link [
+ dup find-vocab-root >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %
From 993a647ccc8237a99c5258a489737a0c673e705f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 18 Mar 2008 21:43:29 -0500
Subject: [PATCH 080/197] Parser fixes
---
core/generic/generic-tests.factor | 28 ++++++++++++
core/generic/generic.factor | 25 +++++------
core/parser/parser-tests.factor | 52 ++++++++++++++---------
core/prettyprint/prettyprint-tests.factor | 12 ++++++
core/prettyprint/prettyprint.factor | 6 +--
core/words/words.factor | 5 +++
6 files changed, 93 insertions(+), 35 deletions(-)
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index 2dc699f87b..785600cfb0 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ;
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
+
+GENERIC: generic-forget-test-3
+
+M: f generic-forget-test-3 ;
+
+[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
+
+[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
+
+[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
+
+[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
+
+[ f ] [ f generic-forget-test-3 ] unit-test
+
+: a-word ;
+
+GENERIC: a-generic
+
+M: integer a-generic a-word ;
+
+[ ] [ \ integer \ a-generic method "m" set ] unit-test
+
+[ t ] [ "m" get \ a-word usage memq? ] unit-test
+
+[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
+
+[ f ] [ "m" get \ a-word usage memq? ] unit-test
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index ad31831e94..8fe5e4921a 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -104,20 +104,25 @@ M: method-spec definition
first2 method definition ;
: forget-method ( class generic -- )
- check-method
- [ delete-at* ] with-methods
- [ forget-word ] [ drop ] if ;
+ dup generic? [
+ [ delete-at* ] with-methods
+ [ forget-word ] [ drop ] if
+ ] [
+ 2drop
+ ] if ;
M: method-spec forget*
- first2 forget-method ;
+ first2 method forget* ;
M: method-body definer
drop \ M: \ ; ;
M: method-body forget*
- dup "method-class" word-prop
- swap "method-generic" word-prop
- forget-method ;
+ dup "forgotten" word-prop [ drop ] [
+ dup "method-class" word-prop
+ over "method-generic" word-prop forget-method
+ t "forgotten" set-word-prop
+ ] if ;
: implementors* ( classes -- words )
all-words [
@@ -149,16 +154,12 @@ M: assoc update-methods ( assoc -- )
make-generic
] if ;
-GENERIC: subwords ( word -- seq )
-
-M: word subwords drop f ;
-
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add ;
M: generic forget-word
- dup subwords [ forget-word ] each (forget-word) ;
+ dup subwords [ forget ] each (forget-word) ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index a69e28ab97..3095f23be1 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -397,35 +397,47 @@ IN: parser.tests
] unit-test
[ ] [
- "IN: parser.tests TUPLE: foo ; GENERIC: foo"
- <string-reader> "redefining-a-class-5" parse-stream drop
+ [
+ "redefining-a-class-5" forget-source
+ "redefining-a-class-6" forget-source
+ "redefining-a-class-7" forget-source
+ ] with-compilation-unit
] unit-test
-[ ] [
- "IN: parser.tests M: f foo ;"
- <string-reader> "redefining-a-class-6" parse-stream drop
-] unit-test
+2 [
+ [ ] [
+ "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+ <string-reader> "redefining-a-class-5" parse-stream drop
+ ] unit-test
-[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
+ [ ] [
+ "IN: parser.tests M: f foo ;"
+ <string-reader> "redefining-a-class-6" parse-stream drop
+ ] unit-test
-[ ] [
- "IN: parser.tests TUPLE: foo ; GENERIC: foo"
- <string-reader> "redefining-a-class-5" parse-stream drop
-] unit-test
+ [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
-[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
+ [ ] [
+ "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+ <string-reader> "redefining-a-class-5" parse-stream drop
+ ] unit-test
-[ ] [
- "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+ [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
+
+ [ ] [
+ "IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-7" parse-stream drop
-] unit-test
+ ] unit-test
-[ ] [
- "IN: parser.tests TUPLE: foo ;"
- <string-reader> "redefining-a-class-7" parse-stream drop
-] unit-test
+ [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
-[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
+ [ ] [
+ "IN: parser.tests TUPLE: foo ;"
+ <string-reader> "redefining-a-class-7" parse-stream drop
+ ] unit-test
+
+ [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
+] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ]
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 20130d7f7e..8df97effb6 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -317,3 +317,15 @@ unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test
+
+GENERIC: generic-see-test-with-f ( obj -- obj )
+
+M: f generic-see-test-with-f ;
+
+[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
+ [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
+] unit-test
+
+[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
+ [ \ f \ generic-see-test-with-f method see ] with-string-writer
+] unit-test
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 6cb03e4199..8bce81650f 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -172,13 +172,13 @@ M: hook-generic synopsis*
stack-effect. ;
M: method-spec synopsis*
- dup definer. [ pprint-word ] each ;
+ first2 method synopsis* ;
M: method-body synopsis*
dup dup
definer.
- "method-class" word-prop pprint*
- "method-generic" word-prop pprint* ;
+ "method-class" word-prop pprint-word
+ "method-generic" word-prop pprint-word ;
M: mixin-instance synopsis*
dup definer.
diff --git a/core/words/words.factor b/core/words/words.factor
index 73b877fdbb..a36cca00ac 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -169,7 +169,12 @@ SYMBOL: changed-words
"declared-effect" "constructor-quot" "delimiter"
} reset-props ;
+GENERIC: subwords ( word -- seq )
+
+M: word subwords drop f ;
+
: reset-generic ( word -- )
+ dup subwords [ forget ] each
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;
From d04eb777ff0dfc4f1f3d91db4d6adc8a1aef147d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 18 Mar 2008 21:45:04 -0500
Subject: [PATCH 081/197] Update bootstrap code for loader changes
---
core/bootstrap/primitives.factor | 6 +-----
core/bootstrap/syntax.factor | 4 +---
2 files changed, 2 insertions(+), 8 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 52067b888c..0b686e3c7f 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -87,11 +87,7 @@ call
"words.private"
"vectors"
"vectors.private"
-} [
- dup find-vocab-root swap create-vocab
- [ set-vocab-root ] keep
- f swap set-vocab-source-loaded?
-] each
+} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone class<map set
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 4df5a68e97..a4e87f28d8 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -3,9 +3,7 @@
USING: words sequences vocabs kernel ;
IN: bootstrap.syntax
-"syntax" create-vocab
-"resource:core" over set-vocab-root
-f swap set-vocab-source-loaded?
+"syntax" create-vocab drop
{
"!"
From 4b37c9098ef8be2b9471d80d889af7bbe1d61d81 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 16:54:42 +1300
Subject: [PATCH 082/197] Use multiline for parsing EBNF string
---
extra/peg/ebnf/ebnf.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 5d7d7297ef..4563783ab0 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
- peg.parsers unicode.categories ;
+ peg.parsers unicode.categories multiline ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -182,4 +182,4 @@ DEFER: 'choice'
f
] if* ;
-: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
+: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing
From cc9a17b551980b43b016bdc7154bcf7c65d12ccf Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 17:00:53 +1300
Subject: [PATCH 083/197] Use choice* and seq* in ebnf
---
extra/peg/ebnf/ebnf.factor | 70 ++++++++++++++++++++++++--------------
1 file changed, 45 insertions(+), 25 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4563783ab0..81fc215bd9 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -100,33 +100,46 @@ M: ebnf (generate-parser) ( ast -- id )
DEFER: 'rhs'
: 'non-terminal' ( -- parser )
- CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string <ebnf-non-terminal> ] action ;
+ [
+ CHAR: a CHAR: z range ,
+ "-" token [ first ] action ,
+ ] choice* repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
- "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
+ [
+ "'" token hide ,
+ [ CHAR: ' = not ] satisfy repeat1 ,
+ "'" token hide ,
+ ] seq* [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser )
- 'non-terminal' 'terminal' 2array choice ;
+ [
+ 'non-terminal' ,
+ 'terminal' ,
+ ] choice* ;
DEFER: 'choice'
: 'group' ( -- parser )
- "(" token sp hide
- [ 'choice' sp ] delay
- ")" token sp hide
- 3array seq [ first ] action ;
+ [
+ "(" token sp hide ,
+ [ 'choice' sp ] delay ,
+ ")" token sp hide ,
+ ] seq* [ first ] action ;
: 'repeat0' ( -- parser )
- "{" token sp hide
- [ 'choice' sp ] delay
- "}" token sp hide
- 3array seq [ first <ebnf-repeat0> ] action ;
+ [
+ "{" token sp hide ,
+ [ 'choice' sp ] delay ,
+ "}" token sp hide ,
+ ] seq* [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser )
- "[" token sp hide
- [ 'choice' sp ] delay
- "]" token sp hide
- 3array seq [ first <ebnf-optional> ] action ;
+ [
+ "[" token sp hide ,
+ [ 'choice' sp ] delay ,
+ "]" token sp hide ,
+ ] seq* [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser )
[
@@ -134,8 +147,7 @@ DEFER: 'choice'
'group' sp ,
'repeat0' sp ,
'optional' sp ,
- ] { } make choice
- repeat1 [
+ ] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
@@ -145,18 +157,26 @@ DEFER: 'choice'
] action ;
: 'action' ( -- parser )
- "=>" token hide
- [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
- 2array seq [ first <ebnf-action> ] action ;
+ [
+ "=>" token hide ,
+ [
+ [ blank? ] satisfy ensure-not ,
+ [ drop t ] satisfy ,
+ ] seq* [ first ] action repeat1 [ >string ] action sp ,
+ ] seq* [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser )
- 'choice' 'action' sp optional 2array seq ;
+ [
+ 'choice' ,
+ 'action' sp optional ,
+ ] seq* ;
: 'rule' ( -- parser )
- 'non-terminal' [ ebnf-non-terminal-symbol ] action
- "=" token sp hide
- 'rhs'
- 3array seq [ first2 <ebnf-rule> ] action ;
+ [
+ 'non-terminal' [ ebnf-non-terminal-symbol ] action ,
+ "=" token sp hide ,
+ 'rhs' ,
+ ] seq* [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
From 757853812271dbeb31c97f5d33d2f4bf14f9f55f Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 17:34:28 +1300
Subject: [PATCH 084/197] Minor tidyup of ebnf
---
extra/peg/ebnf/ebnf-tests.factor | 17 +++++++++++++
extra/peg/ebnf/ebnf.factor | 42 ++++++++++++++++++++++++--------
2 files changed, 49 insertions(+), 10 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 452da8df05..156f8e9389 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -97,3 +97,20 @@ IN: peg.ebnf.tests
} [
"one [ two ] three" 'choice' parse parse-result-ast
] unit-test
+
+{ "foo" } [
+ "\"foo\"" 'identifier' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "'foo'" 'identifier' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+] unit-test
+
+{ "foo" } [
+ "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+] unit-test
+
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 81fc215bd9..9a3b70fa1c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
- peg.parsers unicode.categories multiline ;
+ peg.parsers unicode.categories multiline combinators.lib ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -99,18 +99,40 @@ M: ebnf (generate-parser) ( ast -- id )
DEFER: 'rhs'
+: 'identifier' ( -- parser )
+ #! Return a parser that parses an identifer delimited by
+ #! a quotation character. The quotation can be single
+ #! or double quotes. The AST produced is the identifier
+ #! between the quotes.
+ [
+ [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,
+ [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
+ ] choice* [ >string ] action ;
+
: 'non-terminal' ( -- parser )
- [
- CHAR: a CHAR: z range ,
- "-" token [ first ] action ,
- ] choice* repeat1 [ >string <ebnf-non-terminal> ] action ;
+ #! A non-terminal is the name of another rule. It can
+ #! be any non-blank character except for characters used
+ #! in the EBNF syntax itself.
+ [
+ {
+ [ dup blank? ]
+ [ dup CHAR: " = ]
+ [ dup CHAR: ' = ]
+ [ dup CHAR: | = ]
+ [ dup CHAR: { = ]
+ [ dup CHAR: } = ]
+ [ dup CHAR: = = ]
+ [ dup CHAR: ) = ]
+ [ dup CHAR: ( = ]
+ [ dup CHAR: ] = ]
+ [ dup CHAR: [ = ]
+ } || not nip
+ ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
- [
- "'" token hide ,
- [ CHAR: ' = not ] satisfy repeat1 ,
- "'" token hide ,
- ] seq* [ first >string <ebnf-terminal> ] action ;
+ #! A terminal is an identifier enclosed in quotations
+ #! and it represents the literal value of the identifier.
+ 'identifier' [ <ebnf-terminal> ] action ;
: 'element' ( -- parser )
[
From 708d55fb8ef4777cb3464b498d794d04a7f96a3a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 17:37:08 +1300
Subject: [PATCH 085/197] Add syntax word for ebnf
---
extra/peg/ebnf/ebnf.factor | 21 +++++++++++++--------
1 file changed, 13 insertions(+), 8 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 9a3b70fa1c..e2977a28fb 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -99,6 +99,11 @@ M: ebnf (generate-parser) ( ast -- id )
DEFER: 'rhs'
+: syntax ( string -- parser )
+ #! Parses the string, ignoring white space, and
+ #! does not put the result in the AST.
+ token sp hide ;
+
: 'identifier' ( -- parser )
#! Return a parser that parses an identifer delimited by
#! a quotation character. The quotation can be single
@@ -144,23 +149,23 @@ DEFER: 'choice'
: 'group' ( -- parser )
[
- "(" token sp hide ,
+ "(" syntax ,
[ 'choice' sp ] delay ,
- ")" token sp hide ,
+ ")" syntax ,
] seq* [ first ] action ;
: 'repeat0' ( -- parser )
[
- "{" token sp hide ,
+ "{" syntax ,
[ 'choice' sp ] delay ,
- "}" token sp hide ,
+ "}" syntax ,
] seq* [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser )
[
- "[" token sp hide ,
+ "[" syntax ,
[ 'choice' sp ] delay ,
- "]" token sp hide ,
+ "]" syntax ,
] seq* [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser )
@@ -196,12 +201,12 @@ DEFER: 'choice'
: 'rule' ( -- parser )
[
'non-terminal' [ ebnf-non-terminal-symbol ] action ,
- "=" token sp hide ,
+ "=" syntax ,
'rhs' ,
] seq* [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
- 'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
+ 'rule' sp "." syntax list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
From 9403d97e22c1e0e59ce4285b033b4db5e4f18b2b Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 17:52:22 +1300
Subject: [PATCH 086/197] Add syntax-pack and grouped to ebnf refactoring
---
extra/peg/ebnf/ebnf.factor | 35 +++++++++++++++++------------------
1 file changed, 17 insertions(+), 18 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e2977a28fb..fce7a8d3bd 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -104,6 +104,11 @@ DEFER: 'rhs'
#! does not put the result in the AST.
token sp hide ;
+: syntax-pack ( begin parser end -- parser )
+ #! Parse 'parser' surrounded by syntax elements
+ #! begin and end.
+ [ syntax ] dipd syntax pack ;
+
: 'identifier' ( -- parser )
#! Return a parser that parses an identifer delimited by
#! a quotation character. The quotation can be single
@@ -147,26 +152,20 @@ DEFER: 'rhs'
DEFER: 'choice'
+: grouped ( begin quot end -- parser )
+ #! Parse a group of choices, where the delimiter for the
+ #! group is specified by 'begin' and 'end'. The quotation
+ #! should produce the AST to be the result of the parser.
+ [ [ 'choice' sp ] delay swap action ] dip syntax-pack ;
+
: 'group' ( -- parser )
- [
- "(" syntax ,
- [ 'choice' sp ] delay ,
- ")" syntax ,
- ] seq* [ first ] action ;
+ "(" [ ] ")" grouped ;
: 'repeat0' ( -- parser )
- [
- "{" syntax ,
- [ 'choice' sp ] delay ,
- "}" syntax ,
- ] seq* [ first <ebnf-repeat0> ] action ;
+ "{" [ <ebnf-repeat0> ] "}" grouped ;
: 'optional' ( -- parser )
- [
- "[" syntax ,
- [ 'choice' sp ] delay ,
- "]" syntax ,
- ] seq* [ first <ebnf-optional> ] action ;
+ "[" [ <ebnf-optional> ] "]" grouped ;
: 'sequence' ( -- parser )
[
@@ -174,14 +173,14 @@ DEFER: 'choice'
'group' sp ,
'repeat0' sp ,
'optional' sp ,
- ] choice* repeat1 [
+ ] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
- ] action ;
+ ] action ;
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
- ] action ;
+ ] action ;
: 'action' ( -- parser )
[
From eef6ae782730ba22a779997023c20d71730abcae Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 18:07:25 +1300
Subject: [PATCH 087/197] Remove need for '.' to terminate rule lines in EBNF
---
extra/peg/ebnf/ebnf.factor | 19 ++++++++++++++-----
1 file changed, 14 insertions(+), 5 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index fce7a8d3bd..e95fc4f9d4 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -145,10 +145,17 @@ DEFER: 'rhs'
'identifier' [ <ebnf-terminal> ] action ;
: 'element' ( -- parser )
- [
- 'non-terminal' ,
- 'terminal' ,
- ] choice* ;
+ #! An element of a rule. It can be a terminal or a
+ #! non-terminal but must not be followed by a "=".
+ #! The latter indicates that it is the beginning of a
+ #! new rule.
+ [
+ [
+ 'non-terminal' ,
+ 'terminal' ,
+ ] choice* ,
+ "=" syntax ensure-not ,
+ ] seq* [ first ] action ;
DEFER: 'choice'
@@ -168,6 +175,8 @@ DEFER: 'choice'
"[" [ <ebnf-optional> ] "]" grouped ;
: 'sequence' ( -- parser )
+ #! A sequence of terminals and non-terminals, including
+ #! groupings of those.
[
'element' sp ,
'group' sp ,
@@ -205,7 +214,7 @@ DEFER: 'choice'
] seq* [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
- 'rule' sp "." syntax list-of [ <ebnf> ] action ;
+ 'rule' sp repeat1 [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
From 208c88c44949f72f62d9cd6ffbf700d301232963 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 18:35:45 +1300
Subject: [PATCH 088/197] Update pl0 for ebnf changes, and add more tests
---
extra/peg/pl0/pl0-tests.factor | 88 +++++++++++++++++++++++++++++++++-
extra/peg/pl0/pl0.factor | 35 +++++++-------
2 files changed, 105 insertions(+), 18 deletions(-)
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index fa8ac89f57..bf321d54e9 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.pl0 ;
+USING: kernel tools.test peg peg.pl0 multiline sequences ;
IN: peg.pl0.tests
{ "abc" } [
@@ -11,3 +11,89 @@ IN: peg.pl0.tests
{ 55 } [
"55abc" number parse parse-result-ast
] unit-test
+
+{ t } [
+ <"
+VAR x, squ;
+
+PROCEDURE square;
+BEGIN
+ squ := x * x
+END;
+
+BEGIN
+ x := 1;
+ WHILE x <= 10 DO
+ BEGIN
+ CALL square;
+ x := x + 1;
+ END
+END.
+"> program parse parse-result-remaining empty?
+] unit-test
+
+{ f } [
+ <"
+CONST
+ m = 7,
+ n = 85;
+
+VAR
+ x, y, z, q, r;
+
+PROCEDURE multiply;
+VAR a, b;
+
+BEGIN
+ a := x;
+ b := y;
+ z := 0;
+ WHILE b > 0 DO BEGIN
+ IF ODD b THEN z := z + a;
+ a := 2 * a;
+ b := b / 2;
+ END
+END;
+
+PROCEDURE divide;
+VAR w;
+BEGIN
+ r := x;
+ q := 0;
+ w := y;
+ WHILE w <= r DO w := 2 * w;
+ WHILE w > y DO BEGIN
+ q := 2 * q;
+ w := w / 2;
+ IF w <= r THEN BEGIN
+ r := r - w;
+ q := q + 1
+ END
+ END
+END;
+
+PROCEDURE gcd;
+VAR f, g;
+BEGIN
+ f := x;
+ g := y;
+ WHILE f # g DO BEGIN
+ IF f < g THEN g := g - f;
+ IF g < f THEN f := f - g;
+ END;
+ z := f
+END;
+
+BEGIN
+ x := m;
+ y := n;
+ CALL multiply;
+ x := 25;
+ y := 3;
+ CALL divide;
+ x := 84;
+ y := 36;
+ CALL gcd;
+END.
+ "> program parse parse-result-remaining empty?
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index 6844eb44dc..1ef7a23b41 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -1,30 +1,31 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences
-peg peg.ebnf peg.parsers memoize ;
+peg peg.ebnf peg.parsers memoize namespaces ;
IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
MEMO: ident ( -- parser )
- CHAR: a CHAR: z range
- CHAR: A CHAR: Z range 2array choice repeat1
- [ >string ] action ;
+ [
+ CHAR: a CHAR: z range ,
+ CHAR: A CHAR: Z range ,
+ ] choice* repeat1 [ >string ] action ;
MEMO: number ( -- parser )
CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
<EBNF
-program = block '.' .
-block = [ 'const' ident '=' number { ',' ident '=' number } ';' ]
- [ 'var' ident { ',' ident } ';' ]
- { 'procedure' ident ';' [ block ';' ] } statement .
-statement = [ ident ':=' expression | 'call' ident |
- 'begin' statement {';' statement } 'end' |
- 'if' condition 'then' statement |
- 'while' condition 'do' statement ] .
-condition = 'odd' expression |
- expression ('=' | '#' | '<=' | '<' | '>=' | '>') expression .
-expression = ['+' | '-'] term {('+' | '-') term } .
-term = factor {('*' | '/') factor } .
-factor = ident | number | '(' expression ')'
+program = block "."
+block = [ "CONST" ident "=" number { "," ident "=" number } ";" ]
+ [ "VAR" ident { "," ident } ";" ]
+ { "PROCEDURE" ident ";" [ block ";" ] } statement
+statement = [ ident ":=" expression | "CALL" ident |
+ "BEGIN" statement {";" statement } "END" |
+ "IF" condition "THEN" statement |
+ "WHILE" condition "DO" statement ]
+condition = "ODD" expression |
+ expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression
+expression = ["+" | "-"] term {("+" | "-") term }
+term = factor {("*" | "/") factor }
+factor = ident | number | "(" expression ")"
EBNF>
From ede3e068a072f259502578b5f21b5dfde8702680 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 18 Mar 2008 22:56:54 -0700
Subject: [PATCH 089/197] Get COM interface working. Add IShellFolder interface
to shell32.dll to play around with
---
extra/windows/com/authors.txt | 1 +
extra/windows/com/com-docs.factor | 15 ++++
extra/windows/com/com-tests.factor | 88 ++++++++++---------
extra/windows/com/com.factor | 13 ++-
extra/windows/com/summary.txt | 1 +
extra/windows/com/syntax/authors.txt | 1 +
extra/windows/com/syntax/summary.txt | 1 +
extra/windows/com/syntax/syntax-docs.factor | 26 ++++++
extra/windows/com/syntax/syntax.factor | 27 ++++--
extra/windows/com/syntax/tags.txt | 3 +
extra/windows/com/tags.txt | 3 +
extra/windows/ole32/authors.txt | 1 +
extra/windows/ole32/ole32.factor | 16 ++++
extra/windows/shell32/shell32.factor | 97 ++++++++++++++++++++-
14 files changed, 238 insertions(+), 55 deletions(-)
create mode 100755 extra/windows/com/authors.txt
create mode 100755 extra/windows/com/com-docs.factor
create mode 100755 extra/windows/com/summary.txt
create mode 100755 extra/windows/com/syntax/authors.txt
create mode 100755 extra/windows/com/syntax/summary.txt
create mode 100755 extra/windows/com/syntax/syntax-docs.factor
create mode 100755 extra/windows/com/syntax/tags.txt
create mode 100755 extra/windows/com/tags.txt
create mode 100755 extra/windows/ole32/authors.txt
diff --git a/extra/windows/com/authors.txt b/extra/windows/com/authors.txt
new file mode 100755
index 0000000000..6a1b3e726a
--- /dev/null
+++ b/extra/windows/com/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor
new file mode 100755
index 0000000000..901a88675f
--- /dev/null
+++ b/extra/windows/com/com-docs.factor
@@ -0,0 +1,15 @@
+USING: help.markup help.syntax io kernel math quotations
+multiline ;
+IN: windows.com
+
+HELP: com-query-interface
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
+{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;
+
+HELP: com-add-ref
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;
+
+HELP: com-release
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;
diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor
index 2e6e8a9c22..4a2f465fef 100755
--- a/extra/windows/com/com-tests.factor
+++ b/extra/windows/com/com-tests.factor
@@ -1,5 +1,6 @@
USING: kernel windows.com windows.com.syntax windows.ole32
-alien alien.syntax tools.test libc ;
+alien alien.syntax tools.test libc alien.c-types arrays.lib
+namespaces arrays continuations ;
IN: windows.com.tests
! Create some test COM interfaces
@@ -9,13 +10,17 @@ COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
HRESULT returnError ( ) ;
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
- int getX ( ) ;
+ int getX ( )
void setX ( int newX ) ;
! Implement the IInherited interface in factor using alien-callbacks
+C-STRUCT: test-implementation
+ { "void*" "vtbl" }
+ { "int" "x" } ;
+
: QueryInterface-callback
- "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 -rot set-void*-nth ]
+ "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
alien-callback ;
: AddRef-callback
"ULONG" { "void*" } "stdcall" [ drop 2 ]
@@ -24,33 +29,20 @@ COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
"ULONG" { "void*" } "stdcall" [ drop 1 ]
alien-callback ;
: returnOK-callback
- "HRESULT"{ "void*" } "stdcall" [ drop S_OK ]
+ "HRESULT" { "void*" } "stdcall" [ drop S_OK ]
alien-callback ;
: returnError-callback
- "HRESULT"{ "void*" } "stdcall" [ drop E_FAIL ]
+ "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]
alien-callback ;
: getX-callback
- "int" { "void*" } "stdcall" [ test-interface-x ]
+ "int" { "void*" } "stdcall" [ test-implementation-x ]
alien-callback ;
: setX-callback
- "void" { "void*" "int" } "stdcall" [ swap set-test-interface-x ]
+ "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
alien-callback ;
SYMBOL: +test-implementation-vtbl+
-{
- QueryInterface-callback
- AddRef-callback
- Release-callback
- returnOK-callback
- returnError-callback
- getX-callback
- setX-callback
-} [ execute ] map >c-void*-array
-+test-implementation-vtbl+ set
-
-C-STRUCT: test-implementation
- { "void*" "vtbl" }
- { "int" "x" } ;
+SYMBOL: +guinea-pig-implementation+
: (make-test-implementation) ( x imp -- imp )
[ set-test-implementation-x ] keep
@@ -59,29 +51,43 @@ C-STRUCT: test-implementation
: <test-implementation> ( x -- imp )
"test-implementation" <c-object> (make-test-implementation) ;
-! Test that the words defined by COM-INTERFACE: do their magic
-
-"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
-"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
-"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
-S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
-E_FAIL 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
-1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
-
-! Test that the helper functions for QueryInterface, AddRef, Release work
-
: <malloced-test-implementation> ( x -- imp )
"test-implementation" heap-size malloc (make-test-implementation) ;
-SYMBOL: +guinea-pig-implementation+
+QueryInterface-callback
+AddRef-callback
+Release-callback
+returnOK-callback
+returnError-callback
+getX-callback
+setX-callback
+7 narray >c-void*-array
+dup byte-length [
+ [ byte-array>memory ] keep
+ +test-implementation-vtbl+ set
-0 <malloced-test-implementation> +guinea-pig-implementation+ set
-[
- +guinea-pig-implementation+ get 1array [
- +guinea-pig-implementation+ get IUnknown-iid com-query-interface
- ] unit-test
+ ! Test that the words defined by COM-INTERFACE: do their magic
- { } [ +guinea-pig-implementation+ get com-add-ref ] unit-test
- { } [ +guinea-pig-implementation+ get com-release ] unit-test
-] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+ "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
+ "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
+ "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
+ S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
+ E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
+ 1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
+ ! Test that the helper functions for QueryInterface, AddRef, Release work
+
+ 0 <malloced-test-implementation> +guinea-pig-implementation+ set
+ [
+ +guinea-pig-implementation+ get 1array [
+ +guinea-pig-implementation+ get com-add-ref
+ ] unit-test
+
+ { } [ +guinea-pig-implementation+ get com-release ] unit-test
+
+ +guinea-pig-implementation+ get 1array [
+ +guinea-pig-implementation+ get IUnknown-iid com-query-interface
+ ] unit-test
+
+ ] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+] with-malloc
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
index 477eaad038..b78d9b5b91 100755
--- a/extra/windows/com/com.factor
+++ b/extra/windows/com/com.factor
@@ -1,5 +1,5 @@
USING: alien alien.c-types windows.com.syntax windows.ole32
-windows.types continuations ;
+windows.types continuations kernel ;
IN: windows.com
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
@@ -8,10 +8,15 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
ULONG Release ( ) ;
: com-query-interface ( interface iid -- interface' )
- f <void*> [ IUnknown::QueryInterface ] keep *void* ;
+ f <void*>
+ [ IUnknown::QueryInterface ole32-error ] keep
+ *void* ;
-: com-add-ref ( interface -- )
- IUnknown::AddRef drop ; inline
+: com-add-ref ( interface -- interface )
+ [ IUnknown::AddRef drop ] keep ; inline
: com-release ( interface -- )
IUnknown::Release drop ; inline
+
+: with-com-interface ( interface quot -- )
+ [ keep ] [ com-release ] [ ] cleanup ; inline
diff --git a/extra/windows/com/summary.txt b/extra/windows/com/summary.txt
new file mode 100755
index 0000000000..779367e673
--- /dev/null
+++ b/extra/windows/com/summary.txt
@@ -0,0 +1 @@
+COM interface
diff --git a/extra/windows/com/syntax/authors.txt b/extra/windows/com/syntax/authors.txt
new file mode 100755
index 0000000000..6a1b3e726a
--- /dev/null
+++ b/extra/windows/com/syntax/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/windows/com/syntax/summary.txt b/extra/windows/com/syntax/summary.txt
new file mode 100755
index 0000000000..6c2977a108
--- /dev/null
+++ b/extra/windows/com/syntax/summary.txt
@@ -0,0 +1 @@
+Parsing words for defining COM interfaces
diff --git a/extra/windows/com/syntax/syntax-docs.factor b/extra/windows/com/syntax/syntax-docs.factor
new file mode 100755
index 0000000000..fa06d5e4e7
--- /dev/null
+++ b/extra/windows/com/syntax/syntax-docs.factor
@@ -0,0 +1,26 @@
+USING: help.markup help.syntax io kernel math quotations
+multiline ;
+IN: windows.com.syntax
+
+HELP: COM-INTERFACE:
+{ $syntax <"
+COM-INTERFACE: <interface> <parent> <iid>
+ <function-1> ( <params1> )
+ <function-2> ( <params2> )
+ ... ;
+"> }
+{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
+{ $code <"
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+ HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+ ULONG AddRef ( )
+ ULONG Release ( ) ;
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+ HRESULT returnOK ( )
+ HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+ int getX ( )
+ void setX ( int newX ) ;
+"> } ;
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 9068d75d16..32e7433d88 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -1,15 +1,21 @@
USING: alien alien.c-types kernel windows.ole32
combinators.lib parser splitting sequences.lib
sequences namespaces new-slots combinators.cleave
-assocs quotations shuffle ;
+assocs quotations shuffle accessors words macros
+alien.syntax fry ;
IN: windows.com.syntax
<PRIVATE
-: com-invoke ( ... interface-ptr n return parameters -- )
- "stdcall" [
- [ *void* ] dip void*-nth
- ] 3 ndip alien-indirect ; inline
+C-STRUCT: com-interface
+ { "void*" "vtbl" } ;
+
+MACRO: com-invoke ( n return parameters -- )
+ dup length -roll
+ '[
+ , npick com-interface-vtbl , swap void*-nth , ,
+ "stdcall" alien-indirect
+ ] ;
TUPLE: com-interface-definition name parent iid functions ;
C: <com-interface-definition> com-interface-definition
@@ -18,7 +24,9 @@ TUPLE: com-function-definition name return parameters ;
C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+
-H{ } +com-interface-definitions+ set-global
++com-interface-definitions+ get-global
+[ H{ } +com-interface-definitions+ set-global ]
+unless
: find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [
@@ -40,6 +48,7 @@ H{ } +com-interface-definitions+ set-global
: parse-com-functions ( -- functions )
";" parse-tokens { ")" } split
+ [ empty? not ] subset
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
@@ -55,17 +64,17 @@ H{ } +com-interface-definitions+ set-global
: (define-word-for-function) ( function interface n -- )
-rot [ (function-word) swap ] 2keep drop
{ return>> parameters>> } get-slots
- [ [ com-invoke ] 3curry ] keep
- length [ npick ] curry swap compose
+ [ com-invoke ] 3curry
define ;
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
+ [ name>> "com-interface" swap typedef ]
[
dup all-functions
[ (define-word-for-function) ] with each-index
]
- bi ;
+ tri ;
PRIVATE>
diff --git a/extra/windows/com/syntax/tags.txt b/extra/windows/com/syntax/tags.txt
new file mode 100755
index 0000000000..49139bab66
--- /dev/null
+++ b/extra/windows/com/syntax/tags.txt
@@ -0,0 +1,3 @@
+windows
+com
+bindings
diff --git a/extra/windows/com/tags.txt b/extra/windows/com/tags.txt
new file mode 100755
index 0000000000..49139bab66
--- /dev/null
+++ b/extra/windows/com/tags.txt
@@ -0,0 +1,3 @@
+windows
+com
+bindings
diff --git a/extra/windows/ole32/authors.txt b/extra/windows/ole32/authors.txt
new file mode 100755
index 0000000000..6a1b3e726a
--- /dev/null
+++ b/extra/windows/ole32/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
index ec0b02bc3f..44ea853af0 100755
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -13,6 +13,10 @@ C-STRUCT: GUID
TYPEDEF: void* REFGUID
TYPEDEF: void* LPUNKNOWN
TYPEDEF: ushort* LPOLESTR
+TYPEDEF: ushort* LPCOLESTR
+
+TYPEDEF: REFGUID REFIID
+TYPEDEF: REFGUID REFCLSID
FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
@@ -24,6 +28,18 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
+: MK_ALT HEX: 20 ; inline
+: DROPEFFECT_NONE 0 ; inline
+: DROPEFFECT_COPY 1 ; inline
+: DROPEFFECT_MOVE 2 ; inline
+: DROPEFFECT_LINK 4 ; inline
+: DROPEFFECT_SCROLL HEX: 80000000 ; inline
+: DD_DEFSCROLLINSET 11 ; inline
+: DD_DEFSCROLLDELAY 50 ; inline
+: DD_DEFSCROLLINTERVAL 50 ; inline
+: DD_DEFDRAGDELAY 200 ; inline
+: DD_DEFDRAGMINDIST 2 ; inline
+
: ole32-error ( n -- )
dup S_OK = [
drop
diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
index 1d8d67dad7..e32b2dc058 100755
--- a/extra/windows/shell32/shell32.factor
+++ b/extra/windows/shell32/shell32.factor
@@ -1,5 +1,6 @@
USING: alien alien.c-types alien.syntax combinators
-kernel windows windows.user32 windows.ole32 ;
+kernel windows windows.user32 windows.ole32
+windows.com windows.com.syntax ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
@@ -118,3 +119,97 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
: program-files-common-x86 ( -- str )
CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
+
+: SHCONTF_FOLDERS 32 ; inline
+: SHCONTF_NONFOLDERS 64 ; inline
+: SHCONTF_INCLUDEHIDDEN 128 ; inline
+: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline
+: SHCONTF_NETPRINTERSRCH 512 ; inline
+: SHCONTF_SHAREABLE 1024 ; inline
+: SHCONTF_STORAGE 2048 ; inline
+
+TYPEDEF: DWORD SHCONTF
+
+: SHGDN_NORMAL 0 ; inline
+: SHGDN_INFOLDER 1 ; inline
+: SHGDN_FOREDITING HEX: 1000 ; inline
+: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline
+: SHGDN_FORADDRESSBAR HEX: 4000 ; inline
+: SHGDN_FORPARSING HEX: 8000 ; inline
+
+TYPEDEF: DWORD SHGDNF
+
+: SFGAO_CANCOPY DROPEFFECT_COPY ; inline
+: SFGAO_CANMOVE DROPEFFECT_MOVE ; inline
+: SFGAO_CANLINK DROPEFFECT_LINK ; inline
+: SFGAO_CANRENAME HEX: 00000010 ; inline
+: SFGAO_CANDELETE HEX: 00000020 ; inline
+: SFGAO_HASPROPSHEET HEX: 00000040 ; inline
+: SFGAO_DROPTARGET HEX: 00000100 ; inline
+: SFGAO_CAPABILITYMASK HEX: 00000177 ; inline
+: SFGAO_LINK HEX: 00010000 ; inline
+: SFGAO_SHARE HEX: 00020000 ; inline
+: SFGAO_READONLY HEX: 00040000 ; inline
+: SFGAO_GHOSTED HEX: 00080000 ; inline
+: SFGAO_HIDDEN HEX: 00080000 ; inline
+: SFGAO_DISPLAYATTRMASK HEX: 000F0000 ; inline
+: SFGAO_FILESYSANCESTOR HEX: 10000000 ; inline
+: SFGAO_FOLDER HEX: 20000000 ; inline
+: SFGAO_FILESYSTEM HEX: 40000000 ; inline
+: SFGAO_HASSUBFOLDER HEX: 80000000 ; inline
+: SFGAO_CONTENTSMASK HEX: 80000000 ; inline
+: SFGAO_VALIDATE HEX: 01000000 ; inline
+: SFGAO_REMOVABLE HEX: 02000000 ; inline
+: SFGAO_COMPRESSED HEX: 04000000 ; inline
+: SFGAO_BROWSABLE HEX: 08000000 ; inline
+: SFGAO_NONENUMERATED HEX: 00100000 ; inline
+: SFGAO_NEWCONTENT HEX: 00200000 ; inline
+
+TYPEDEF: ULONG SFGAOF
+
+C-STRUCT: SHITEMID
+ { "USHORT" "cb" }
+ { "BYTE[1]" "abID" } ;
+TYPEDEF: SHITEMID* LPSHITEMID
+TYPEDEF: SHITEMID* LPCSHITEMID
+
+C-STRUCT: ITEMIDLIST
+ { "SHITEMID" "mkid" } ;
+TYPEDEF: ITEMIDLIST* LPITEMIDLIST
+TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
+TYPEDEF: ITEMIDLIST ITEMID_CHILD
+TYPEDEF: ITEMID_CHILD* PITEMID_CHILD
+TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD
+
+: STRRET_WSTR 0 ; inline
+: STRRET_OFFSET 1 ; inline
+: STRRET_CSTR 2 ; inline
+
+C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
+C-STRUCT: STRRET
+ { "int" "uType" }
+ { "STRRET-union" "union" } ;
+
+COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
+ HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
+ HRESULT Skip ( ULONG celt )
+ HRESULT Reset ( )
+ HRESULT Clone ( IEnumIDList** ppenum ) ;
+
+COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
+ HRESULT ParseDisplayName ( HWND hwndOwner, void* pbcReserved, LPOLESTR lpszDisplayName, ULONG* pchEaten, LPITEMIDLIST* ppidl, ULONG* pdwAttributes )
+ HRESULT EnumObjects ( HWND hwndOwner, SHCONTF grfFlags, IEnumIDList** ppenumIDList )
+ HRESULT BindToObject ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvOut )
+ HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj )
+ HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 )
+ HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut )
+ HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut
+ )
+ HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut )
+ HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName )
+ HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ;
+
+FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
+
+FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
+: StrRetToBuf StrRetToBufW ; inline
From 46c21e2580036c81f6d96954f53fb6fd9867997b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 18 Mar 2008 23:02:21 -0700
Subject: [PATCH 090/197] Correct perms on windows/ tree
---
extra/windows/advapi32/advapi32.factor | 0
extra/windows/advapi32/authors.txt | 0
extra/windows/ce/authors.txt | 0
extra/windows/ce/ce.factor | 0
extra/windows/com/authors.txt | 0
extra/windows/com/com-docs.factor | 0
extra/windows/com/com-tests.factor | 0
extra/windows/com/com.factor | 0
extra/windows/com/summary.txt | 0
extra/windows/com/syntax/authors.txt | 0
extra/windows/com/syntax/summary.txt | 0
extra/windows/com/syntax/syntax-docs.factor | 0
extra/windows/com/syntax/syntax.factor | 0
extra/windows/com/syntax/tags.txt | 0
extra/windows/com/tags.txt | 0
extra/windows/errors/authors.txt | 0
extra/windows/errors/errors.factor | 0
extra/windows/gdi32/authors.txt | 0
extra/windows/kernel32/authors.txt | 0
extra/windows/kernel32/kernel32.factor | 0
extra/windows/messages/authors.txt | 0
extra/windows/messages/messages.factor | 0
extra/windows/nt/authors.txt | 0
extra/windows/nt/nt.factor | 0
extra/windows/ole32/authors.txt | 0
extra/windows/ole32/ole32.factor | 0
extra/windows/opengl32/authors.txt | 0
extra/windows/opengl32/opengl32.factor | 0
extra/windows/shell32/authors.txt | 0
extra/windows/shell32/shell32.factor | 3 +--
extra/windows/time/authors.txt | 0
extra/windows/time/time-tests.factor | 0
extra/windows/time/time.factor | 0
extra/windows/types/authors.txt | 0
extra/windows/user32/authors.txt | 0
extra/windows/user32/user32.factor | 0
extra/windows/windows.factor | 0
extra/windows/winsock/authors.txt | 0
extra/windows/winsock/winsock.factor | 0
39 files changed, 1 insertion(+), 2 deletions(-)
mode change 100755 => 100644 extra/windows/advapi32/advapi32.factor
mode change 100755 => 100644 extra/windows/advapi32/authors.txt
mode change 100755 => 100644 extra/windows/ce/authors.txt
mode change 100755 => 100644 extra/windows/ce/ce.factor
mode change 100755 => 100644 extra/windows/com/authors.txt
mode change 100755 => 100644 extra/windows/com/com-docs.factor
mode change 100755 => 100644 extra/windows/com/com-tests.factor
mode change 100755 => 100644 extra/windows/com/com.factor
mode change 100755 => 100644 extra/windows/com/summary.txt
mode change 100755 => 100644 extra/windows/com/syntax/authors.txt
mode change 100755 => 100644 extra/windows/com/syntax/summary.txt
mode change 100755 => 100644 extra/windows/com/syntax/syntax-docs.factor
mode change 100755 => 100644 extra/windows/com/syntax/syntax.factor
mode change 100755 => 100644 extra/windows/com/syntax/tags.txt
mode change 100755 => 100644 extra/windows/com/tags.txt
mode change 100755 => 100644 extra/windows/errors/authors.txt
mode change 100755 => 100644 extra/windows/errors/errors.factor
mode change 100755 => 100644 extra/windows/gdi32/authors.txt
mode change 100755 => 100644 extra/windows/kernel32/authors.txt
mode change 100755 => 100644 extra/windows/kernel32/kernel32.factor
mode change 100755 => 100644 extra/windows/messages/authors.txt
mode change 100755 => 100644 extra/windows/messages/messages.factor
mode change 100755 => 100644 extra/windows/nt/authors.txt
mode change 100755 => 100644 extra/windows/nt/nt.factor
mode change 100755 => 100644 extra/windows/ole32/authors.txt
mode change 100755 => 100644 extra/windows/ole32/ole32.factor
mode change 100755 => 100644 extra/windows/opengl32/authors.txt
mode change 100755 => 100644 extra/windows/opengl32/opengl32.factor
mode change 100755 => 100644 extra/windows/shell32/authors.txt
mode change 100755 => 100644 extra/windows/shell32/shell32.factor
mode change 100755 => 100644 extra/windows/time/authors.txt
mode change 100755 => 100644 extra/windows/time/time-tests.factor
mode change 100755 => 100644 extra/windows/time/time.factor
mode change 100755 => 100644 extra/windows/types/authors.txt
mode change 100755 => 100644 extra/windows/user32/authors.txt
mode change 100755 => 100644 extra/windows/user32/user32.factor
mode change 100755 => 100644 extra/windows/windows.factor
mode change 100755 => 100644 extra/windows/winsock/authors.txt
mode change 100755 => 100644 extra/windows/winsock/winsock.factor
diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/advapi32/authors.txt b/extra/windows/advapi32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/ce/authors.txt b/extra/windows/ce/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/ce/ce.factor b/extra/windows/ce/ce.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/com/authors.txt b/extra/windows/com/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/com/summary.txt b/extra/windows/com/summary.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/com/syntax/authors.txt b/extra/windows/com/syntax/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/com/syntax/summary.txt b/extra/windows/com/syntax/summary.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/com/syntax/syntax-docs.factor b/extra/windows/com/syntax/syntax-docs.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/com/syntax/tags.txt b/extra/windows/com/syntax/tags.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/com/tags.txt b/extra/windows/com/tags.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/errors/authors.txt b/extra/windows/errors/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/errors/errors.factor b/extra/windows/errors/errors.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/gdi32/authors.txt b/extra/windows/gdi32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/kernel32/authors.txt b/extra/windows/kernel32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/messages/authors.txt b/extra/windows/messages/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/nt/authors.txt b/extra/windows/nt/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/nt/nt.factor b/extra/windows/nt/nt.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/ole32/authors.txt b/extra/windows/ole32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/opengl32/authors.txt b/extra/windows/opengl32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/shell32/authors.txt b/extra/windows/shell32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
old mode 100755
new mode 100644
index e32b2dc058..d64fb68cb3
--- a/extra/windows/shell32/shell32.factor
+++ b/extra/windows/shell32/shell32.factor
@@ -203,8 +203,7 @@ COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj )
HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 )
HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut )
- HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut
- )
+ HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut )
HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut )
HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName )
HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ;
diff --git a/extra/windows/time/authors.txt b/extra/windows/time/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/time/time-tests.factor b/extra/windows/time/time-tests.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/types/authors.txt b/extra/windows/types/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/user32/authors.txt b/extra/windows/user32/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/extra/windows/winsock/authors.txt b/extra/windows/winsock/authors.txt
old mode 100755
new mode 100644
diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor
old mode 100755
new mode 100644
From 64135b73e1b029c49af511a9d32307b5c473b52a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 19 Mar 2008 19:15:52 +1300
Subject: [PATCH 091/197] Add support for ensure-not and parsing any single
character to EBNF This allows, for example: foo = {!("_" | "-") .}
This will match zero or more of any character, except for _ or -
---
extra/peg/ebnf/ebnf-tests.factor | 1 +
extra/peg/ebnf/ebnf.factor | 27 +++++++++++++++++++++++++++
2 files changed, 28 insertions(+)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 156f8e9389..86a7a454ed 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -114,3 +114,4 @@ IN: peg.ebnf.tests
"foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
] unit-test
+
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e95fc4f9d4..4dc096ecbd 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -7,6 +7,8 @@ IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
+TUPLE: ebnf-any-character ;
+TUPLE: ebnf-ensure-not group ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
@@ -17,6 +19,8 @@ TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
+C: <ebnf-any-character> ebnf-any-character
+C: <ebnf-ensure-not> ebnf-ensure-not
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
@@ -61,6 +65,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id )
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ;
+M: ebnf-any-character (generate-parser) ( ast -- id )
+ drop [ drop t ] satisfy store-parser ;
+
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
@@ -71,6 +78,9 @@ M: ebnf-sequence (generate-parser) ( ast -- id )
generate-parser get-parser
] map seq store-parser ;
+M: ebnf-ensure-not (generate-parser) ( ast -- id )
+ ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ;
+
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
@@ -136,6 +146,8 @@ DEFER: 'rhs'
[ dup CHAR: ( = ]
[ dup CHAR: ] = ]
[ dup CHAR: [ = ]
+ [ dup CHAR: . = ]
+ [ dup CHAR: ! = ]
} || not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
@@ -144,6 +156,10 @@ DEFER: 'rhs'
#! and it represents the literal value of the identifier.
'identifier' [ <ebnf-terminal> ] action ;
+: 'any-character' ( -- parser )
+ #! A parser to match the symbol for any character match.
+ [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
+
: 'element' ( -- parser )
#! An element of a rule. It can be a terminal or a
#! non-terminal but must not be followed by a "=".
@@ -153,6 +169,7 @@ DEFER: 'rhs'
[
'non-terminal' ,
'terminal' ,
+ 'any-character' ,
] choice* ,
"=" syntax ensure-not ,
] seq* [ first ] action ;
@@ -174,10 +191,20 @@ DEFER: 'choice'
: 'optional' ( -- parser )
"[" [ <ebnf-optional> ] "]" grouped ;
+: 'ensure-not' ( -- parser )
+ #! Parses the '!' syntax to ensure that
+ #! something that matches the following elements do
+ #! not exist in the parse stream.
+ [
+ "!" syntax ,
+ 'group' sp ,
+ ] seq* [ first <ebnf-ensure-not> ] action ;
+
: 'sequence' ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
+ 'ensure-not' sp ,
'element' sp ,
'group' sp ,
'repeat0' sp ,
From de4b699d98a7d14830989d90b51349e7eb98207f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 02:43:23 -0500
Subject: [PATCH 092/197] Documentation update
---
core/alien/alien-docs.factor | 7 ++---
core/alien/c-types/c-types-docs.factor | 32 ++++++++++++++++-------
core/alien/compiler/compiler-tests.factor | 10 +++----
3 files changed, 32 insertions(+), 17 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 95b29ee50b..7bba9d7332 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -210,8 +210,9 @@ $nl
ARTICLE: "alien-callback" "Calling Factor from C"
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsection alien-callback }
-"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
-{ $subsection "alien-callback-gc" } ;
+"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
+{ $subsection "alien-callback-gc" }
+{ $see-also "byte-arrays-gc" } ;
ARTICLE: "dll.private" "DLL handles"
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
@@ -290,7 +291,7 @@ $nl
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
$nl
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
-{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
+{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
{ $subsection "loading-libs" }
{ $subsection "alien-invoke" }
{ $subsection "alien-callback" }
diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor
index fe6873ac3a..8d2b03467b 100755
--- a/core/alien/c-types/c-types-docs.factor
+++ b/core/alien/c-types/c-types-docs.factor
@@ -158,6 +158,19 @@ HELP: define-out
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
+"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
+$nl
+"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
+{ $list
+ "the C function returns"
+ "the C function calls Factor code via a callback"
+}
+"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
+$nl
+"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
+{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
+
ARTICLE: "c-out-params" "Output parameters in C"
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
$nl
@@ -229,13 +242,11 @@ $nl
{ $subsection <c-object> }
{ $subsection <c-array> }
{ $warning
-"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
-$nl
-"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
{ $see-also "c-arrays" } ;
ARTICLE: "malloc" "Manual memory management"
-"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
+"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
@@ -245,8 +256,6 @@ $nl
{ $subsection malloc }
{ $subsection calloc }
{ $subsection realloc }
-"The return value of the above three words must always be checked for a memory allocation failure:"
-{ $subsection check-ptr }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"You can unsafely copy a range of bytes from one memory location to another:"
@@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings"
{ $subsection string>u16-alien }
{ $subsection malloc-char-string }
{ $subsection malloc-u16-string }
-"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
+"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
{ $subsection alien>char-string }
-{ $subsection alien>u16-string } ;
+{ $subsection alien>u16-string }
+"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ARTICLE: "c-data" "Passing data between Factor and C"
-"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
+"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
+$nl
+"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
{ $subsection "c-byte-arrays" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
+"Important guidelines for passing data in byte arrays:"
+{ $subsection "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor
index 7e2e23726b..f9dc426de1 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/core/alien/compiler/compiler-tests.factor
@@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test.
-cpu "arm" = [
- [ "testing" ] [
- "testing" callback-5a callback_test_1
- ] unit-test
-] unless
+! cpu "arm" = [
+! [ "testing" ] [
+! "testing" callback-5a callback_test_1
+! ] unit-test
+! ] unless
: callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
From 36c94f357c95791d16f618e7a7f552a65f1cc304 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 02:43:36 -0500
Subject: [PATCH 093/197] Fix shaker's libc stripping
---
extra/tools/deploy/shaker/strip-libc.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
mode change 100644 => 100755 extra/tools/deploy/shaker/strip-libc.factor
diff --git a/extra/tools/deploy/shaker/strip-libc.factor b/extra/tools/deploy/shaker/strip-libc.factor
old mode 100644
new mode 100755
index 898399b092..ba1436fd17
--- a/extra/tools/deploy/shaker/strip-libc.factor
+++ b/extra/tools/deploy/shaker/strip-libc.factor
@@ -1,10 +1,10 @@
USING: libc.private ;
IN: libc
-: malloc (malloc) ;
+: malloc (malloc) check-ptr ;
+
+: realloc (realloc) check-ptr ;
+
+: calloc (calloc) check-ptr ;
: free (free) ;
-
-: realloc (realloc) ;
-
-: calloc (calloc) ;
From 82d54d37769a30663face16e7bbd6c800bee8171 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 01:18:09 +1300
Subject: [PATCH 094/197] EBNF syntax change [ ... ] is now ( ... )? { ... } is
now ( ... )* Added ( ... )+
---
extra/peg/ebnf/ebnf-tests.factor | 4 ++--
extra/peg/ebnf/ebnf.factor | 34 +++++++++++++++++++++++---------
2 files changed, 27 insertions(+), 11 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 86a7a454ed..6838bf3eca 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -83,7 +83,7 @@ IN: peg.ebnf.tests
}
}
} [
- "one {(two | three) four}" 'choice' parse parse-result-ast
+ "one ((two | three) four)*" 'choice' parse parse-result-ast
] unit-test
{
@@ -95,7 +95,7 @@ IN: peg.ebnf.tests
}
}
} [
- "one [ two ] three" 'choice' parse parse-result-ast
+ "one ( two )? three" 'choice' parse parse-result-ast
] unit-test
{ "foo" } [
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4dc096ecbd..59695998ce 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -12,6 +12,7 @@ TUPLE: ebnf-ensure-not group ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
+TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ;
@@ -24,6 +25,7 @@ C: <ebnf-ensure-not> ebnf-ensure-not
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
+C: <ebnf-repeat1> ebnf-repeat1
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
@@ -84,6 +86,9 @@ M: ebnf-ensure-not (generate-parser) ( ast -- id )
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
+M: ebnf-repeat1 (generate-parser) ( ast -- id )
+ ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ;
+
M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ;
@@ -176,20 +181,30 @@ DEFER: 'rhs'
DEFER: 'choice'
-: grouped ( begin quot end -- parser )
- #! Parse a group of choices, where the delimiter for the
- #! group is specified by 'begin' and 'end'. The quotation
- #! should produce the AST to be the result of the parser.
- [ [ 'choice' sp ] delay swap action ] dip syntax-pack ;
-
+: grouped ( quot suffix -- parser )
+ #! Parse a group of choices, with a suffix indicating
+ #! the type of group (repeat0, repeat1, etc) and
+ #! an quot that is the action that produces the AST.
+ "(" [ 'choice' sp ] delay ")" syntax-pack
+ swap 2seq
+ [ first ] rot compose action ;
+
: 'group' ( -- parser )
- "(" [ ] ")" grouped ;
+ #! A grouping with no suffix. Used for precedence.
+ [ ] [
+ "*" token sp ensure-not ,
+ "+" token sp ensure-not ,
+ "?" token sp ensure-not ,
+ ] seq* hide grouped ;
: 'repeat0' ( -- parser )
- "{" [ <ebnf-repeat0> ] "}" grouped ;
+ [ <ebnf-repeat0> ] "*" syntax grouped ;
+
+: 'repeat1' ( -- parser )
+ [ <ebnf-repeat1> ] "+" syntax grouped ;
: 'optional' ( -- parser )
- "[" [ <ebnf-optional> ] "]" grouped ;
+ [ <ebnf-optional> ] "?" syntax grouped ;
: 'ensure-not' ( -- parser )
#! Parses the '!' syntax to ensure that
@@ -208,6 +223,7 @@ DEFER: 'choice'
'element' sp ,
'group' sp ,
'repeat0' sp ,
+ 'repeat1' sp ,
'optional' sp ,
] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
From c0b7bdf823001f4389e7f13df86d05a16dba0822 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 01:25:57 +1300
Subject: [PATCH 095/197] Add *, + and ? to list of non-allowed ebnf identifier
characteres
---
extra/peg/ebnf/ebnf.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 59695998ce..b500d82e98 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -153,6 +153,9 @@ DEFER: 'rhs'
[ dup CHAR: [ = ]
[ dup CHAR: . = ]
[ dup CHAR: ! = ]
+ [ dup CHAR: * = ]
+ [ dup CHAR: + = ]
+ [ dup CHAR: ? = ]
} || not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
From 65fabeec11956cf7d2d7ddacd50b33b7d6e10823 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 02:16:30 +1300
Subject: [PATCH 096/197] remove => action and replace it with [[ code ]] in
EBNF Previously the action had to be a factor word and could only appear at
the end of a rule:
: aword ( ast -- ast ) drop V{ 1 2 } ;
<EBNF foo = "a" "b" => aword EBNF>
Now actions can appear anywhere after an element, and can be any factor code between [[ ... ]] delimiters:
<EBNF foo = "a" "b" [[ drop V{ 1 2 } ]] EBNF>
<EBNF foo = "a" [[ drop 1 ]] "b" [[ drop 2 ]] EBNF>
Unfortunately since this means the ebnf>quot code uses the equivalent of eval, it no longer compiles nicely since it can't be inferred. The generated parsers however do compile.
---
extra/peg/ebnf/ebnf-tests.factor | 12 +++++++++++-
extra/peg/ebnf/ebnf.factor | 25 ++++++++++++++-----------
2 files changed, 25 insertions(+), 12 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 6838bf3eca..63cec2f120 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf ;
+USING: kernel tools.test peg peg.ebnf compiler.units ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -114,4 +114,14 @@ IN: peg.ebnf.tests
"foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
] unit-test
+{ V{ "a" "b" } } [
+ "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+] unit-test
+{ V{ 1 "b" } } [
+ "foo='a' [[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+] unit-test
+
+{ V{ 1 2 } } [
+ "foo='a' [[ drop 1 ]] 'b' [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index b500d82e98..2e0740663a 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
- peg.parsers unicode.categories multiline combinators.lib ;
+ peg.parsers unicode.categories multiline combinators.lib
+ splitting ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -15,7 +16,7 @@ TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
-TUPLE: ebnf-action word ;
+TUPLE: ebnf-action code ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
@@ -98,7 +99,7 @@ M: ebnf-rule (generate-parser) ( ast -- id )
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
- ebnf-action-word search 1quotation
+ ebnf-action-code string-lines parse-lines
last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id )
@@ -237,20 +238,22 @@ DEFER: 'choice'
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
-: 'action' ( -- parser )
+: 'factor-code' ( -- parser )
[
- "=>" token hide ,
- [
- [ blank? ] satisfy ensure-not ,
- [ drop t ] satisfy ,
- ] seq* [ first ] action repeat1 [ >string ] action sp ,
- ] seq* [ first <ebnf-action> ] action ;
+ "]]" token ensure-not ,
+ [ drop t ] satisfy ,
+ ] seq* [ first ] action repeat0 [ >string ] action ;
+
+: 'action' ( -- parser )
+ "[[" 'factor-code' "]]" syntax-pack [ <ebnf-action> ] action ;
: 'rhs' ( -- parser )
[
'choice' ,
'action' sp optional ,
- ] seq* ;
+ ] seq* repeat1 [
+ dup length 1 = [ first ] [ <ebnf-sequence> ] if
+ ] action ;
: 'rule' ( -- parser )
[
From 92d8140d87cff4015eb9d396296db0d015d7e0dd Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 03:05:40 +1300
Subject: [PATCH 097/197] Change ebnf-action to properly nest with attached
parser This allows removal of last-parser hack. Syntax of EBNF changes
though. Now an action must attach to a group:
<EBNF foo = (a b c) [[ ...act on group... ]] EBNF>
---
extra/peg/ebnf/ebnf-tests.factor | 18 ++++--------
extra/peg/ebnf/ebnf.factor | 49 ++++++++++++++------------------
2 files changed, 27 insertions(+), 40 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 63cec2f120..8846a9c94c 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -15,11 +15,8 @@ IN: peg.ebnf.tests
{
T{ ebnf-rule f
"digit"
- V{
- T{ ebnf-choice f
- V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
- }
- f
+ T{ ebnf-choice f
+ V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
}
}
} [
@@ -29,11 +26,8 @@ IN: peg.ebnf.tests
{
T{ ebnf-rule f
"digit"
- V{
- T{ ebnf-sequence f
- V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
- }
- f
+ T{ ebnf-sequence f
+ V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
}
}
} [
@@ -119,9 +113,9 @@ IN: peg.ebnf.tests
] unit-test
{ V{ 1 "b" } } [
- "foo='a' [[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+ "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
] unit-test
{ V{ 1 2 } } [
- "foo='a' [[ drop 1 ]] 'b' [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+ "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 2e0740663a..e2c2dd5006 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -16,7 +16,7 @@ TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
-TUPLE: ebnf-action code ;
+TUPLE: ebnf-action parser code ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
@@ -34,12 +34,10 @@ C: <ebnf> ebnf
SYMBOL: parsers
SYMBOL: non-terminals
-SYMBOL: last-parser
: reset-parser-generation ( -- )
V{ } clone parsers set
- H{ } clone non-terminals set
- f last-parser set ;
+ H{ } clone non-terminals set ;
: store-parser ( parser -- number )
parsers get [ push ] keep length 1- ;
@@ -57,7 +55,7 @@ SYMBOL: last-parser
GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id )
- (generate-parser) dup last-parser set ;
+ (generate-parser) ;
M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ;
@@ -99,15 +97,12 @@ M: ebnf-rule (generate-parser) ( ast -- id )
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
- ebnf-action-code string-lines parse-lines
- last-parser get get-parser swap action store-parser ;
+ [ ebnf-action-parser generate-parser get-parser ] keep
+ ebnf-action-code string-lines parse-lines action store-parser ;
M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ;
-M: f (generate-parser) ( ast -- id )
- drop last-parser get ;
-
M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [
generate-parser
@@ -199,6 +194,7 @@ DEFER: 'choice'
"*" token sp ensure-not ,
"+" token sp ensure-not ,
"?" token sp ensure-not ,
+ "[[" token sp ensure-not ,
] seq* hide grouped ;
: 'repeat0' ( -- parser )
@@ -210,6 +206,19 @@ DEFER: 'choice'
: 'optional' ( -- parser )
[ <ebnf-optional> ] "?" syntax grouped ;
+: 'factor-code' ( -- parser )
+ [
+ "]]" token ensure-not ,
+ [ drop t ] satisfy ,
+ ] seq* [ first ] action repeat0 [ >string ] action ;
+
+: 'action' ( -- parser )
+ [
+ "(" [ 'choice' sp ] delay ")" syntax-pack ,
+ "[[" 'factor-code' "]]" syntax-pack ,
+ ] seq* [ first2 <ebnf-action> ] action ;
+
+
: 'ensure-not' ( -- parser )
#! Parses the '!' syntax to ensure that
#! something that matches the following elements do
@@ -229,6 +238,7 @@ DEFER: 'choice'
'repeat0' sp ,
'repeat1' sp ,
'optional' sp ,
+ 'action' sp ,
] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
@@ -237,29 +247,12 @@ DEFER: 'choice'
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
-
-: 'factor-code' ( -- parser )
- [
- "]]" token ensure-not ,
- [ drop t ] satisfy ,
- ] seq* [ first ] action repeat0 [ >string ] action ;
-
-: 'action' ( -- parser )
- "[[" 'factor-code' "]]" syntax-pack [ <ebnf-action> ] action ;
-
-: 'rhs' ( -- parser )
- [
- 'choice' ,
- 'action' sp optional ,
- ] seq* repeat1 [
- dup length 1 = [ first ] [ <ebnf-sequence> ] if
- ] action ;
: 'rule' ( -- parser )
[
'non-terminal' [ ebnf-non-terminal-symbol ] action ,
"=" syntax ,
- 'rhs' ,
+ 'choice' ,
] seq* [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
From 97b58580a7a0bb633d88c1f7855ba3ad7a2cbf03 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 03:30:53 +1300
Subject: [PATCH 098/197] Add expression evaluator example for EBNF
---
extra/peg/expr/authors.txt | 1 +
extra/peg/expr/expr.factor | 30 ++++++++++++++++++++++++++++++
extra/peg/expr/summary.txt | 1 +
extra/peg/expr/tags.txt | 1 +
4 files changed, 33 insertions(+)
create mode 100644 extra/peg/expr/authors.txt
create mode 100644 extra/peg/expr/expr.factor
create mode 100644 extra/peg/expr/summary.txt
create mode 100644 extra/peg/expr/tags.txt
diff --git a/extra/peg/expr/authors.txt b/extra/peg/expr/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/peg/expr/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor
new file mode 100644
index 0000000000..ed13ac0e50
--- /dev/null
+++ b/extra/peg/expr/expr.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays strings math.parser sequences
+peg peg.ebnf peg.parsers memoize math ;
+IN: peg.expr
+
+: operator-fold ( lhs seq -- value )
+ #! Perform a fold of a lhs, followed by a sequence of pairs being
+ #! { operator rhs } in to a tree structure of the correct precedence.
+ swap [ first2 swap call ] reduce ;
+
+<EBNF
+
+times = ("*") [[ drop [ * ] ]]
+divide = ("/") [[ drop [ / ] ]]
+add = ("+") [[ drop [ + ] ]]
+subtract = ("-") [[ drop [ - ] ]]
+
+digit = "0" | "1" | "2" | "3" | "4" |
+ "5" | "6" | "7" | "8" | "9"
+number = ((digit)+) [[ concat string>number ]]
+
+value = number | ("(" expr ")") [[ second ]]
+product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
+sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]]
+expr = sum
+EBNF>
+
+: eval-expr ( string -- number )
+ expr parse parse-result-ast ;
\ No newline at end of file
diff --git a/extra/peg/expr/summary.txt b/extra/peg/expr/summary.txt
new file mode 100644
index 0000000000..6c3c140b2b
--- /dev/null
+++ b/extra/peg/expr/summary.txt
@@ -0,0 +1 @@
+Simple expression evaluator using EBNF
diff --git a/extra/peg/expr/tags.txt b/extra/peg/expr/tags.txt
new file mode 100644
index 0000000000..9da56880c0
--- /dev/null
+++ b/extra/peg/expr/tags.txt
@@ -0,0 +1 @@
+parsing
From 3d43c0350eaa1a0ab88dd14cdd9bd6dd8499d75a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 13:26:39 -0500
Subject: [PATCH 099/197] Fix USING: in alien.factor
---
core/alien/alien.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index ca35cb3696..fc89586b68 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
kernel.private tuples bit-arrays byte-arrays float-arrays
-shuffle arrays macros ;
+arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
From 005de2515629b53e1c1c823798cfdb0f791d5f67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Wed, 19 Mar 2008 14:25:53 -0500
Subject: [PATCH 100/197] Cocoa UI cleanup
---
extra/cocoa/windows/windows.factor | 3 ++-
extra/tools/walker/walker.factor | 4 +---
extra/ui/cocoa/cocoa.factor | 35 +++++++++++++++++++-----------
extra/ui/cocoa/views/views.factor | 9 +++++++-
extra/ui/windows/windows.factor | 16 --------------
5 files changed, 33 insertions(+), 34 deletions(-)
diff --git a/extra/cocoa/windows/windows.factor b/extra/cocoa/windows/windows.factor
index b45acaf852..74a181f9a2 100755
--- a/extra/cocoa/windows/windows.factor
+++ b/extra/cocoa/windows/windows.factor
@@ -30,7 +30,8 @@ IN: cocoa.windows
: <ViewWindow> ( view rect -- window )
<NSWindow> [ swap -> setContentView: ] keep
dup dup -> contentView -> setInitialFirstResponder:
- dup 1 -> setAcceptsMouseMovedEvents: ;
+ dup 1 -> setAcceptsMouseMovedEvents:
+ dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
NSWindow over -> frame rot -> styleMask
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 610d3db0a3..6ef5309214 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -30,8 +30,6 @@ DEFER: start-walker-thread
2dup start-walker-thread
] if* ;
-USING: io.streams.c prettyprint ;
-
: show-walker ( -- thread )
get-walker-thread
[ show-walker-hook get call ] keep ;
@@ -40,7 +38,7 @@ USING: io.streams.c prettyprint ;
{
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
- { [ dup not ] [ "Single stepping abandoned" throw ] }
+ { [ dup not ] [ "Single stepping abandoned" rethrow ] }
} cond ;
: break ( -- )
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 572e798bd0..79b7041dcb 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math arrays cocoa cocoa.application command-line
kernel memory namespaces cocoa.messages cocoa.runtime
@@ -8,6 +8,10 @@ ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
core-foundation threads ;
IN: ui.cocoa
+TUPLE: handle view window ;
+
+C: <handle> handle
+
TUPLE: cocoa-ui-backend ;
SYMBOL: stop-after-last-window?
@@ -47,27 +51,30 @@ M: pasteboard set-clipboard-contents
dup rot world>NSRect <ViewWindow>
dup install-window-delegate
over -> release
- 2array
+ <handle>
] keep set-world-handle ;
M: cocoa-ui-backend set-title ( string world -- )
- world-handle second swap <NSString> -> setTitle: ;
+ world-handle handle-window swap <NSString> -> setTitle: ;
: enter-fullscreen ( world -- )
- world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
+ world-handle handle-view
+ NSScreen -> mainScreen
+ f -> enterFullScreenMode:withOptions:
+ drop ;
: exit-fullscreen ( world -- )
- world-handle first f -> exitFullScreenModeWithOptions: ;
+ world-handle handle-view f -> exitFullScreenModeWithOptions: ;
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen* ( world -- ? )
- world-handle first -> isInFullScreenMode zero? not ;
+ world-handle handle-view -> isInFullScreenMode zero? not ;
: auto-position ( world -- )
dup world-loc { 0 0 } = [
- world-handle second -> center
+ world-handle handle-window -> center
] [
drop
] if ;
@@ -75,27 +82,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
M: cocoa-ui-backend (open-window) ( world -- )
dup gadget-window
dup auto-position
- world-handle second f -> makeKeyAndOrderFront: ;
+ world-handle handle-window f -> makeKeyAndOrderFront: ;
M: cocoa-ui-backend (close-window) ( handle -- )
- first unregister-window ;
+ handle-window -> release ;
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
- world-handle second f -> performClose:
+ world-handle [
+ handle-window f -> performClose:
+ ] when*
] when* ;
M: cocoa-ui-backend raise-window* ( world -- )
world-handle [
- second dup f -> orderFront: -> makeKeyWindow
+ handle-window dup f -> orderFront: -> makeKeyWindow
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
M: cocoa-ui-backend select-gl-context ( handle -- )
- first -> openGLContext -> makeCurrentContext ;
+ handle-view -> openGLContext -> makeCurrentContext ;
M: cocoa-ui-backend flush-gl-context ( handle -- )
- first -> openGLContext -> flushBuffer ;
+ handle-view -> openGLContext -> flushBuffer ;
SYMBOL: cocoa-init-hook
diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor
index a965e8a30c..5b975f40de 100755
--- a/extra/ui/cocoa/views/views.factor
+++ b/extra/ui/cocoa/views/views.factor
@@ -313,6 +313,7 @@ CLASS: {
{ "dealloc" "void" { "id" "SEL" }
[
drop
+ dup unregister-window
dup remove-observer
SUPER-> dealloc
]
@@ -349,7 +350,13 @@ CLASS: {
{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
[
- 2nip -> contentView window ungraft t
+ 3drop t
+ ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window ungraft
]
} ;
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 0c9c23cf76..f47a82275b 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -376,22 +376,6 @@ SYMBOL: trace-messages?
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
-! ! ! !
-: set-world-dim ( dim world -- )
- swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
- SetWindowPos drop ;
-USE: random
-USE: arrays
-
-: twiddle
- 100 500 random +
- 100 500 random +
- 2array
- "x" get-global find-world
- set-world-dim
- yield ;
-! ! ! !
-
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
From 3591ed402d2a0bda54c548471e83277746f5f7da Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 14:39:08 -0500
Subject: [PATCH 101/197] Simplify vocab.loader even further
---
core/bootstrap/primitives.factor | 1 +
core/vocabs/loader/loader-docs.factor | 2 -
core/vocabs/loader/loader-tests.factor | 10 ++--
core/vocabs/loader/loader.factor | 64 +++++++++--------------
core/vocabs/vocabs-docs.factor | 9 +---
core/vocabs/vocabs.factor | 21 ++++----
extra/help/markup/markup.factor | 2 +-
extra/tools/deploy/deploy-tests.factor | 4 ++
extra/tools/vocabs/browser/browser.factor | 2 +-
extra/tools/vocabs/vocabs.factor | 48 ++++++++---------
10 files changed, 69 insertions(+), 94 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 0b686e3c7f..e407bfd143 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -30,6 +30,7 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone changed-words set
+H{ } clone root-cache set
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index c7652c34c7..c0542f7b96 100755
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -43,8 +43,6 @@ HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
-{ vocab-root find-vocab-root } related-words
-
HELP: no-vocab
{ $values { "name" "a vocabulary name" } }
{ $description "Throws a " { $link no-vocab } "." }
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 015f54540d..0519096128 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ;
] unit-test
[ T{ vocab-link f "vocabs.loader.test" } ]
-[ "vocabs.loader.test" f >vocab-link ] unit-test
+[ "vocabs.loader.test" >vocab-link ] unit-test
[ t ]
-[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
+[ "kernel" >vocab-link "kernel" vocab = ] unit-test
[ t ] [
"kernel" vocab-files
"kernel" vocab vocab-files
- "kernel" f <vocab-link> vocab-files
+ "kernel" <vocab-link> vocab-files
3array all-equal?
] unit-test
@@ -36,7 +36,7 @@ IN: vocabs.loader.tests
[ { 3 3 3 } ] [
"vocabs.loader.test.2" run
"vocabs.loader.test.2" vocab run
- "vocabs.loader.test.2" f <vocab-link> run
+ "vocabs.loader.test.2" <vocab-link> run
3array
] unit-test
@@ -115,7 +115,7 @@ IN: vocabs.loader.tests
[ 3 ] [ "count-me" get-global ] unit-test
[ { "resource:core/kernel/kernel.factor" 1 } ]
-[ "kernel" f <vocab-link> where ] unit-test
+[ "kernel" <vocab-link> where ] unit-test
[ { "resource:core/kernel/kernel.factor" 1 } ]
[ "kernel" vocab where ] unit-test
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 96193ef664..9833b2834f 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -23,15 +23,6 @@ V{
[ >r dup peek r> append add ] when*
"/" join ;
-: vocab-path+ ( vocab path -- newpath )
- swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
- dup ".factor" vocab-dir+ vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
- dup "-docs.factor" vocab-dir+ vocab-path+ ;
-
: vocab-dir? ( root name -- ? )
over [
".factor" vocab-dir+ path+ resource-exists?
@@ -39,14 +30,23 @@ V{
2drop f
] if ;
+SYMBOL: root-cache
+
+H{ } clone root-cache set-global
+
: find-vocab-root ( vocab -- path/f )
- vocab-roots get swap [ vocab-dir? ] curry find nip ;
+ vocab-name root-cache get [
+ vocab-roots get swap [ vocab-dir? ] curry find nip
+ ] cache ;
-M: string vocab-root
- vocab dup [ vocab-root ] when ;
+: vocab-path+ ( vocab path -- newpath )
+ swap find-vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-M: vocab-link vocab-root
- vocab-link-root ;
+: vocab-source-path ( vocab -- path/f )
+ dup ".factor" vocab-dir+ vocab-path+ ;
+
+: vocab-docs-path ( vocab -- path/f )
+ dup "-docs.factor" vocab-dir+ vocab-path+ ;
SYMBOL: load-help?
@@ -56,7 +56,7 @@ SYMBOL: load-help?
: load-source ( vocab -- )
[ source-wasn't-loaded ] keep
- [ vocab-source-path bootstrap-file ] keep
+ [ vocab-source-path [ bootstrap-file ] when* ] keep
source-was-loaded ;
: docs-were-loaded t swap set-vocab-docs-loaded? ;
@@ -70,18 +70,9 @@ SYMBOL: load-help?
docs-were-loaded
] [ drop ] if ;
-: create-vocab-with-root ( name root -- vocab )
- swap create-vocab [ set-vocab-root ] keep ;
-
-: update-root ( vocab -- )
- dup vocab-root
- [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
-
: reload ( name -- )
[
- dup vocab [
- dup update-root dup load-source load-docs
- ] [ no-vocab ] ?if
+ dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
@@ -104,22 +95,17 @@ SYMBOL: blacklist
GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab)
- dup update-root
-
- dup vocab-root [
- [
- dup vocab-source-loaded? [ dup load-source ] unless
- dup vocab-docs-loaded? [ dup load-docs ] unless
- ] [ [ swap add-to-blacklist ] keep rethrow ] recover
- ] when drop ;
-
-M: string (load-vocab)
- ! ".private" ?tail drop
- dup find-vocab-root >vocab-link (load-vocab) ;
+ [
+ dup vocab-source-loaded? [ dup load-source ] unless
+ dup vocab-docs-loaded? [ dup load-docs ] unless
+ drop
+ ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: vocab-link (load-vocab)
- dup vocab-name swap vocab-root dup
- [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
+ vocab-name create-vocab (load-vocab) ;
+
+M: string (load-vocab)
+ create-vocab (load-vocab) ;
[
[
diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor
index f16a33f0d5..0d55499620 100755
--- a/core/vocabs/vocabs-docs.factor
+++ b/core/vocabs/vocabs-docs.factor
@@ -16,7 +16,6 @@ $nl
{ $subsection vocab }
"Accessors for various vocabulary attributes:"
{ $subsection vocab-name }
-{ $subsection vocab-root }
{ $subsection vocab-main }
{ $subsection vocab-help }
"Looking up existing vocabularies and creating new vocabularies:"
@@ -50,10 +49,6 @@ HELP: vocab-name
{ $values { "vocab" "a vocabulary specifier" } { "name" string } }
{ $description "Outputs the name of a vocabulary." } ;
-HELP: vocab-root
-{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } }
-{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ;
-
HELP: vocab-words
{ $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
{ $description "Outputs the words defined in a vocabulary." } ;
@@ -101,11 +96,11 @@ HELP: child-vocabs
} ;
HELP: vocab-link
-{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known."
+{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name."
$nl
"Vocabulary links are created by calling " { $link >vocab-link } "."
} ;
HELP: >vocab-link
-{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } }
+{ $values { "name" string } { "vocab" "a vocabulary specifier" } }
{ $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 9d281c864b..807e08f73b 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -92,10 +92,10 @@ SYMBOL: load-vocab-hook ! ( name -- )
: child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ;
-TUPLE: vocab-link name root ;
+TUPLE: vocab-link name ;
-: <vocab-link> ( name root -- vocab-link )
- [ dup vocab-root ] unless* vocab-link construct-boa ;
+: <vocab-link> ( name -- vocab-link )
+ vocab-link construct-boa ;
M: vocab-link equal?
over vocab-link?
@@ -106,17 +106,14 @@ M: vocab-link hashcode*
M: vocab-link vocab-name vocab-link-name ;
-GENERIC# >vocab-link 1 ( name root -- vocab )
-
-M: vocab >vocab-link drop ;
-
-M: vocab-link >vocab-link drop ;
-
-M: string >vocab-link
- over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
-
UNION: vocab-spec vocab vocab-link ;
+GENERIC: >vocab-link ( name -- vocab )
+
+M: vocab-spec >vocab-link ;
+
+M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
+
: forget-vocab ( vocab -- )
dup words forget-all
vocab-name dictionary get delete-at ;
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 7cfe384bde..47a40d6948 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -159,7 +159,7 @@ M: f print-element drop ;
[ first ($long-link) ] ($subsection) ;
: ($vocab-link) ( text vocab -- )
- dup vocab-root >vocab-link write-link ;
+ >vocab-link write-link ;
: $vocab-subsection ( element -- )
[
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 6d3385d0a4..c7a97e7787 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -26,6 +26,10 @@ tools.deploy.backend math sequences io.launcher arrays ;
[ ] [ "hello-ui" shake-and-bake ] unit-test
+[ "staging.math-compiler-ui-strip.image" ] [
+ "hello-ui" deploy-config [ staging-image-name ] bind
+] unit-test
+
[ t ] [
2000000 small-enough?
] unit-test
diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor
index 2c66305d47..06eba5f65c 100755
--- a/extra/tools/vocabs/browser/browser.factor
+++ b/extra/tools/vocabs/browser/browser.factor
@@ -127,7 +127,7 @@ C: <vocab-author> vocab-author
: $describe-vocab ( element -- )
first
dup describe-children
- dup vocab-root over vocab-dir? [
+ dup find-vocab-root [
dup describe-summary
dup describe-tags
dup describe-authors
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 82c411cbfb..2f2e834808 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -6,29 +6,27 @@ memoize inspector sorting splitting combinators source-files
io debugger continuations compiler.errors init io.crc32 ;
IN: tools.vocabs
-: vocab-tests-file, ( vocab -- )
- dup "-tests.factor" vocab-dir+ vocab-path+
- dup resource-exists? [ , ] [ drop ] if ;
+: vocab-tests-file ( vocab -- path )
+ dup "-tests.factor" vocab-dir+ vocab-path+ dup
+ [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ;
-: vocab-tests-dir, ( vocab -- )
- dup vocab-dir "tests" path+ vocab-path+
- dup resource-exists? [
- dup ?resource-path directory keys
- [ ".factor" tail? ] subset
- [ path+ , ] with each
- ] [ drop ] if ;
+: vocab-tests-dir ( vocab -- paths )
+ dup vocab-dir "tests" path+ vocab-path+ dup [
+ dup resource-exists? [
+ dup ?resource-path directory keys
+ [ ".factor" tail? ] subset
+ [ path+ ] with map
+ ] [ drop f ] if
+ ] [ drop f ] if ;
: vocab-tests ( vocab -- tests )
- dup vocab-root dup [
- [
- >vocab-link dup
- vocab-tests-file,
- vocab-tests-dir,
- ] { } make
- ] [ 2drop f ] if ;
+ [
+ dup vocab-tests-file [ , ] when*
+ vocab-tests-dir [ % ] when*
+ ] { } make ;
: vocab-files ( vocab -- seq )
- dup find-vocab-root >vocab-link [
+ [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %
@@ -53,12 +51,8 @@ IN: tools.vocabs
: modified-docs ( vocabs -- seq )
[ vocab-docs-path ] modified ;
-: update-roots ( vocabs -- )
- [ dup find-vocab-root swap vocab set-vocab-root ] each ;
-
: to-refresh ( prefix -- modified-sources modified-docs )
child-vocabs
- dup update-roots
dup modified-sources swap modified-docs ;
: vocab-heading. ( vocab -- )
@@ -180,7 +174,7 @@ M: vocab-link summary vocab-summary ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
- 2dup vocab-dir? [ 2dup swap >vocab-link , ] when
+ 2dup vocab-dir? [ dup >vocab-link , ] when
vocabs-in-dir
] with each ;
@@ -233,7 +227,7 @@ MEMO: all-vocabs-seq ( -- seq )
: unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . add ] unless
vocabs
- [ vocab-root not ] subset
+ [ find-vocab-root not ] subset
[
vocab-name swap ?head CHAR: . rot member? not and
] with subset
@@ -241,10 +235,9 @@ MEMO: all-vocabs-seq ( -- seq )
: all-child-vocabs ( prefix -- assoc )
vocab-roots get [
- over dupd dupd (all-child-vocabs)
- swap [ >vocab-link ] curry map
+ dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
- f rot unrooted-child-vocabs 2array add ;
+ swap unrooted-child-vocabs f swap 2array add ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap [
@@ -262,6 +255,7 @@ MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] map>set ;
: reset-cache ( -- )
+ root-cache get-global clear-assoc
\ (vocab-file-contents) reset-memoized
\ all-vocabs-seq reset-memoized
\ all-authors reset-memoized
From 5904d3fffae0c1fed2797df1bde32f956130e32d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 15:24:49 -0500
Subject: [PATCH 102/197] Fix set-timeout with dan's new encoding stuff
---
core/classes/classes-tests.factor | 12 +++++++-----
core/io/encodings/encodings.factor | 26 ++++++++++++++------------
extra/io/timeouts/timeouts.factor | 6 +++++-
extra/tools/deploy/deploy-tests.factor | 3 ++-
4 files changed, 28 insertions(+), 19 deletions(-)
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index 7d43ee905a..f97f088845 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -1,6 +1,6 @@
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes io.streams.string
+tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ;
IN: classes.tests
@@ -63,10 +63,6 @@ UNION: c a b ;
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
-! Test generic see and parsing
-[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
-[ [ \ bah see ] with-string-writer ] unit-test
-
! Test redefinition of classes
UNION: union-1 fixnum float ;
@@ -180,6 +176,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
+USE: io.streams.string
+
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
@@ -224,3 +222,7 @@ MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
+
+! Test generic see and parsing
+[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
+[ [ \ bah see ] with-string-writer ] unit-test
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 4cd43ef455..03ea2262a8 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -14,19 +14,26 @@ GENERIC: encode-char ( char stream encoding -- )
GENERIC: <decoder> ( stream decoding -- newstream )
-GENERIC: <encoder> ( stream encoding -- newstream )
-
: replacement-char HEX: fffd ;
-! Decoding
-
-<PRIVATE
+TUPLE: decoder stream code cr ;
TUPLE: decode-error ;
: decode-error ( -- * ) \ decode-error construct-empty throw ;
-TUPLE: decoder stream code cr ;
+GENERIC: <encoder> ( stream encoding -- newstream )
+
+TUPLE: encoder stream code ;
+
+TUPLE: encode-error ;
+
+: encode-error ( -- * ) \ encode-error construct-empty throw ;
+
+! Decoding
+
+<PRIVATE
+
M: tuple-class <decoder> construct-empty <decoder> ;
M: tuple <decoder> f decoder construct-boa ;
@@ -101,12 +108,6 @@ M: decoder stream-readln ( stream -- str )
M: decoder dispose decoder-stream dispose ;
! Encoding
-
-TUPLE: encode-error ;
-
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
-
-TUPLE: encoder stream code ;
M: tuple-class <encoder> construct-empty <encoder> ;
M: tuple <encoder> encoder construct-boa ;
@@ -132,6 +133,7 @@ INSTANCE: encoder plain-writer
: redecode ( stream encoding -- newstream )
over decoder? [ >r decoder-stream r> ] when <decoder> ;
+
PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
index ef660a6f0d..f1031e98e2 100755
--- a/extra/io/timeouts/timeouts.factor
+++ b/extra/io/timeouts/timeouts.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel calendar alarms io.streams.duplex ;
+USING: kernel calendar alarms io.streams.duplex io.encodings ;
IN: io.timeouts
! Won't need this with new slot accessors
@@ -12,6 +12,10 @@ M: duplex-stream set-timeout
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;
+M: decoder set-timeout decoder-stream set-timeout ;
+
+M: encoder set-timeout encoder-stream set-timeout ;
+
GENERIC: timed-out ( obj -- )
M: object timed-out drop ;
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index c7a97e7787..3b88d14fb3 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -1,6 +1,7 @@
IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config
-tools.deploy.backend math sequences io.launcher arrays ;
+tools.deploy.backend math sequences io.launcher arrays
+namespaces ;
: shake-and-bake ( vocab -- )
"." resource-path [
From 40aab45282ead3651f45ebce0d064352276f95b8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:16:35 -0500
Subject: [PATCH 103/197] add do-while and use it in generate
---
extra/combinators/lib/lib.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 7c93f805cd..6f1fbbe2c0 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -8,13 +8,6 @@ continuations ;
IN: combinators.lib
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: generate ( generator predicate -- obj )
- #! Call 'generator' until the result satisfies 'predicate'.
- [ slip over slip ] 2keep
- roll [ 2drop ] [ rot drop generate ] if ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -165,3 +158,10 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
: retry ( quot n -- )
[ drop ] rot compose attempt-all ; inline
+
+: do-while ( pred body tail -- )
+ >r tuck 2slip r> while ;
+
+: generate ( generator predicate -- obj )
+ [ dup ] swap [ dup [ nip ] unless not ] 3compose
+ swap [ ] do-while ;
From b3527a17df070ccb0212e52bfab214ee7ecc5df0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:18:03 -0500
Subject: [PATCH 104/197] redo random/
---
.../blum-blum-shub/blum-blum-shub.factor | 36 ++++++
extra/random/dummy/dummy.factor | 11 ++
.../random/{ => mersenne-twister}/authors.txt | 0
.../mersenne-twister-docs.factor.bak} | 10 +-
.../mersenne-twister-tests.factor | 30 +++++
.../mersenne-twister/mersenne-twister.factor | 80 +++++++++++++
.../random/{ => mersenne-twister}/summary.txt | 0
extra/random/random-tests.factor | 15 ---
extra/random/random.factor | 112 ++++--------------
extra/random/unix/unix.factor | 22 ++++
extra/random/windows/windows.factor | 3 +
11 files changed, 209 insertions(+), 110 deletions(-)
create mode 100644 extra/random/blum-blum-shub/blum-blum-shub.factor
create mode 100644 extra/random/dummy/dummy.factor
rename extra/random/{ => mersenne-twister}/authors.txt (100%)
rename extra/random/{random-docs.factor => mersenne-twister/mersenne-twister-docs.factor.bak} (78%)
create mode 100644 extra/random/mersenne-twister/mersenne-twister-tests.factor
create mode 100755 extra/random/mersenne-twister/mersenne-twister.factor
rename extra/random/{ => mersenne-twister}/summary.txt (100%)
delete mode 100644 extra/random/random-tests.factor
mode change 100755 => 100644 extra/random/random.factor
create mode 100644 extra/random/unix/unix.factor
create mode 100644 extra/random/windows/windows.factor
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
new file mode 100644
index 0000000000..e1ba48281a
--- /dev/null
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -0,0 +1,36 @@
+USING: kernel math sequences namespaces
+math.miller-rabin combinators.cleave combinators.lib
+math.functions new-slots accessors random ;
+IN: random.blum-blum-shub
+
+! TODO: take (log log M) bits instead of 1 bit
+! Blum Blum Shub, M = pq
+TUPLE: blum-blum-shub x n ;
+
+C: <blum-blum-shub> blum-blum-shub
+
+: generate-bbs-primes ( numbits -- p q )
+ #! two primes congruent to 3 (mod 4)
+ [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
+
+IN: crypto
+: <blum-blum-shub> ( numbits -- blum-blum-shub )
+ #! returns a Blum-Blum-Shub tuple
+ generate-bbs-primes *
+ [ find-relative-prime ] keep
+ blum-blum-shub construct-boa ;
+
+! 256 make-bbs blum-blum-shub set-global
+
+: next-bbs-bit ( bbs -- bit )
+ #! x = x^2 mod n, return low bit of calculated x
+ [ [ x>> 2 ] [ n>> ] bi ^mod ]
+ [ [ >>x ] keep x>> 1 bitand ] bi ;
+
+IN: crypto
+! : random ( n -- n )
+ ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256
+ ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
+
+M: blum-blum-shub random-32 ( bbs -- r )
+ ;
diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor
new file mode 100644
index 0000000000..af6e2365bb
--- /dev/null
+++ b/extra/random/dummy/dummy.factor
@@ -0,0 +1,11 @@
+USING: kernel random math new-slots accessors ;
+IN: random.dummy
+
+TUPLE: random-dummy i ;
+C: <random-dummy> random-dummy
+
+M: random-dummy seed-random ( seed obj -- )
+ (>>i) ;
+
+M: random-dummy random-32 ( obj -- r )
+ [ dup 1+ ] change-i drop ;
diff --git a/extra/random/authors.txt b/extra/random/mersenne-twister/authors.txt
similarity index 100%
rename from extra/random/authors.txt
rename to extra/random/mersenne-twister/authors.txt
diff --git a/extra/random/random-docs.factor b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak
similarity index 78%
rename from extra/random/random-docs.factor
rename to extra/random/mersenne-twister/mersenne-twister-docs.factor.bak
index 1d8334ab31..981b206b29 100644
--- a/extra/random/random-docs.factor
+++ b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak
@@ -1,17 +1,17 @@
USING: help.markup help.syntax math ;
-IN: random
+IN: random.mersenne-twister
ARTICLE: "random-numbers" "Generating random integers"
"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm."
-{ $subsection init-random }
+! { $subsection init-random }
{ $subsection (random) }
{ $subsection random } ;
ABOUT: "random-numbers"
-HELP: init-random
-{ $values { "seed" integer } }
-{ $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ;
+! HELP: init-random
+! { $values { "seed" integer } }
+! { $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ;
HELP: (random)
{ $values { "rand" "an integer between 0 and 2^32-1" } }
diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor
new file mode 100644
index 0000000000..afd9d085b6
--- /dev/null
+++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor
@@ -0,0 +1,30 @@
+USING: kernel math random namespaces random.mersenne-twister
+sequences tools.test ;
+IN: random.mersenne-twister.tests
+USE: tools.walker
+
+: check-random ( max -- ? )
+ dup >r random 0 r> between? ;
+
+[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
+
+: make-100-randoms
+ [ 100 [ 100 random , ] times ] { } make ;
+
+: test-rng ( seed quot -- )
+ >r <mersenne-twister> r> with-random ;
+
+[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
+
+[ 1333075495 ] [
+ 0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng
+] unit-test
+
+[ 1575309035 ] [
+ 0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng
+] unit-test
+
+
+[ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test
+[ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test
+[ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
new file mode 100755
index 0000000000..79101c083e
--- /dev/null
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -0,0 +1,80 @@
+! Copyright (C) 2005, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! mersenne twister based on
+! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
+
+USING: arrays kernel math namespaces sequences
+system init new-slots accessors
+math.ranges combinators.cleave circular random ;
+IN: random.mersenne-twister
+
+<PRIVATE
+
+: new-nth ( seq i -- elt ) swap nth ; inline
+: new-set-nth ( seq obj n -- seq ) pick set-nth ; inline
+
+TUPLE: mersenne-twister seq i ;
+
+: mt-n 624 ; inline
+: mt-m 397 ; inline
+: 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 ( mt y from-elt to -- )
+ >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
+ r> bitxor bitxor r> new-set-nth drop ; inline
+
+: calculate-y ( mt y1 y2 -- y )
+ >r over r>
+ [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline
+
+: (mt-generate) ( mt-seq n -- y to from-elt )
+ [ dup 1+ mt-wrap calculate-y ]
+ [ mt-m + mt-wrap new-nth ]
+ [ nip ] 2tri ;
+
+: mt-generate ( mt -- )
+ [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ]
+ [ 0 >>i drop ] bi ;
+
+: init-mt-first ( seed -- seq )
+ >r mt-n 0 <array> r>
+ HEX: ffffffff bitand 0 new-set-nth ;
+
+: init-mt-formula ( seq i -- f(seq[i]) )
+ tuck new-nth dup -30 shift bitxor 1812433253 * +
+ 1+ HEX: ffffffff bitand ;
+
+: init-mt-rest ( seq -- )
+ mt-n 1- [0,b) [
+ dupd [ init-mt-formula ] keep 1+ new-set-nth drop
+ ] with each ;
+
+: init-mt-seq ( seed -- seq )
+ init-mt-first dup init-mt-rest ;
+
+: mt-temper ( y -- yt )
+ dup -11 shift bitxor
+ dup 7 shift HEX: 9d2c5680 bitand bitxor
+ dup 15 shift HEX: efc60000 bitand bitxor
+ dup -18 shift bitxor ; inline
+
+PRIVATE>
+
+: <mersenne-twister> ( seed -- obj )
+ init-mt-seq 0 mersenne-twister construct-boa
+ dup mt-generate ;
+
+M: mersenne-twister seed-random ( mt seed -- )
+ init-mt-seq >>seq drop ;
+
+M: mersenne-twister random-32 ( mt -- r )
+ dup [ seq>> ] [ i>> ] bi
+ dup mt-n < [ drop 0 pick mt-generate ] unless
+ new-nth mt-temper
+ swap [ 1+ ] change-i drop ;
+
+[ millis <mersenne-twister> \ random set-global ] "random" add-init-hook
diff --git a/extra/random/summary.txt b/extra/random/mersenne-twister/summary.txt
similarity index 100%
rename from extra/random/summary.txt
rename to extra/random/mersenne-twister/summary.txt
diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor
deleted file mode 100644
index d431e57d01..0000000000
--- a/extra/random/random-tests.factor
+++ /dev/null
@@ -1,15 +0,0 @@
-USING: kernel math random namespaces sequences tools.test ;
-IN: random.tests
-
-: check-random ( max -- ? )
- dup >r random 0 r> between? ;
-
-[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
-
-: make-100-randoms
- [ 100 [ 100 random , ] times ] { } make ;
-
-[ f ] [ make-100-randoms make-100-randoms = ] unit-test
-
-[ 1333075495 ] [ 0 init-random 1000 [ drop (random) drop ] each (random) ] unit-test
-[ 1575309035 ] [ 0 init-random 10000 [ drop (random) drop ] each (random) ] unit-test
diff --git a/extra/random/random.factor b/extra/random/random.factor
old mode 100755
new mode 100644
index db2aacd2b0..bbf54e21eb
--- a/extra/random/random.factor
+++ b/extra/random/random.factor
@@ -1,107 +1,39 @@
-! Copyright (C) 2005, 2007 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-
-! mersenne twister based on
-! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-
-USING: arrays kernel math namespaces sequences
-system init alien.c-types ;
+USING: alien.c-types kernel math namespaces sequences
+io.backend ;
IN: random
-<PRIVATE
+HOOK: os-crypto-random-bytes io-backend ( n -- byte-array )
+HOOK: os-random-bytes io-backend ( n -- byte-array )
+HOOK: os-crypto-random-32 io-backend ( -- r )
+HOOK: os-random-32 io-backend ( -- r )
-TUPLE: mersenne-twister seed seq i ;
+GENERIC: seed-random ( tuple seed -- )
+GENERIC: random-32 ( tuple -- r )
-C: <mersenne-twister> mersenne-twister
+: (random-bytes) ( tuple n -- byte-array )
+ [ drop random-32 ] with map >c-uint-array ;
-: mt-n 624 ; inline
-: mt-m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
-: mt-hi HEX: 80000000 ; inline
-: mt-lo HEX: 7fffffff ; inline
+DEFER: random
-SYMBOL: mt
+: random-bytes ( n -- r )
+ [
+ 4 /mod zero? [ 1+ ] unless
+ \ random get swap (random-bytes)
+ ] keep head ;
-: mt-seq ( -- seq )
- mt get mersenne-twister-seq ; inline
-
-: mt-nth ( n -- nth )
- mt-seq nth ; inline
-
-: mt-i ( -- i )
- mt get mersenne-twister-i ; inline
-
-: mti-inc ( -- )
- mt get [ mersenne-twister-i 1+ ] keep set-mersenne-twister-i ; inline
-
-: set-mt-ith ( y i-get i-set -- )
- >r mt-nth >r
- [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r>
- mt-seq set-nth ; inline
-
-: mt-y ( y1 y2 -- y )
- mt-nth mt-lo bitand
- >r mt-nth mt-hi bitand r> bitor ; inline
-
-: mod* ( x n -- y )
- #! no floating point
- 2dup >= [ - ] [ drop ] if ; inline
-
-: (mt-generate) ( n -- y n n+(mt-m) )
- dup [ 1+ 624 mod* mt-y ] keep [ mt-m + 624 mod* ] keep ;
-
-: mt-generate ( -- )
- mt-n [ (mt-generate) set-mt-ith ] each
- 0 mt get set-mersenne-twister-i ;
-
-: init-mt-first ( seed -- seq )
- >r mt-n 0 <array> r>
- HEX: ffffffff bitand 0 pick set-nth ;
-
-: init-mt-formula ( seq i -- f(seq[i]) )
- dup rot nth dup -30 shift bitxor
- 1812433253 * + HEX: ffffffff bitand 1+ ; inline
-
-: init-mt-rest ( seq -- )
- mt-n 1 head* [
- [ init-mt-formula ] 2keep 1+ swap set-nth
- ] with each ;
-
-: mt-temper ( y -- yt )
- dup -11 shift bitxor
- dup 7 shift HEX: 9d2c5680 bitand bitxor
- dup 15 shift HEX: efc60000 bitand bitxor
- dup -18 shift bitxor ; inline
-
-PRIVATE>
-
-: init-random ( seed -- )
- global [
- dup init-mt-first
- [ init-mt-rest ] keep
- 0 <mersenne-twister> mt set
- mt-generate
- ] bind ;
-
-: (random) ( -- rand )
- global [
- mt-i dup mt-n < [ drop mt-generate 0 ] unless
- mt-nth mti-inc
- mt-temper
- ] bind ;
-
-: big-random ( n -- r )
- [ drop (random) ] map >c-uint-array byte-array>bignum ;
-
-: random-256 ( -- r ) 8 big-random ; inline
+: random-bits ( n -- r ) 2^ random ;
: random ( seq -- elt )
dup empty? [
drop f
] [
[
- length dup log2 31 + 32 /i big-random swap mod
+ length dup log2 7 + 8 /i
+ random-bytes byte-array>bignum swap mod
] keep nth
] if ;
-[ millis init-random ] "random" add-init-hook
+: with-random ( tuple quot -- )
+ \ random swap with-variable ; inline
diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor
new file mode 100644
index 0000000000..f41a3ae0e8
--- /dev/null
+++ b/extra/random/unix/unix.factor
@@ -0,0 +1,22 @@
+USING: alien.c-types io io.files io.nonblocking kernel
+namespaces random io.encodings.binary singleton ;
+IN: random.unix
+
+SINGLETON: unix-random
+
+: file-read-unbuffered ( n path -- bytes )
+ over default-buffer-size [
+ binary <file-reader> [ read ] with-stream
+ ] with-variable ;
+
+M: unix-random os-crypto-random-bytes ( n -- byte-array )
+ "/dev/random" file-read-unbuffered ;
+
+M: unix-random os-random-bytes ( n -- byte-array )
+ "/dev/urandom" file-read-unbuffered ;
+
+M: unix-random os-crypto-random-32 ( -- r )
+ 4 os-crypto-random-bytes *uint ;
+
+M: unix-random os-random-32 ( -- r )
+ 4 os-random-bytes *uint ;
diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor
new file mode 100644
index 0000000000..8b3c1012c8
--- /dev/null
+++ b/extra/random/windows/windows.factor
@@ -0,0 +1,3 @@
+IN: random.windows
+
+! M: windows-io
From 5296c907d909be2f73176356485427bdfdc72d51 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:19:00 -0500
Subject: [PATCH 105/197] remove random-bits
---
extra/math/miller-rabin/miller-rabin.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index 3985906b32..ea7f02829d 100755
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -19,8 +19,6 @@ SYMBOL: trials
: next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ;
-: random-bits ( m -- n ) 2^ random ; foldable
-
TUPLE: positive-even-expected n ;
: (factor-2s) ( r s -- r s )
From 9c74ba2f2f4b6b090cfe0ab6adee3adda83b51ee Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:19:15 -0500
Subject: [PATCH 106/197] remove extra crypto file
---
extra/crypto/blum-blum-shub.factor | 36 ------------------------------
1 file changed, 36 deletions(-)
delete mode 100644 extra/crypto/blum-blum-shub.factor
diff --git a/extra/crypto/blum-blum-shub.factor b/extra/crypto/blum-blum-shub.factor
deleted file mode 100644
index a1c196d08e..0000000000
--- a/extra/crypto/blum-blum-shub.factor
+++ /dev/null
@@ -1,36 +0,0 @@
-USING: kernel math sequences namespaces crypto math-contrib ;
-IN: crypto-internals
-
-! TODO: take (log log M) bits instead of 1 bit
-! Blum Blum Shub, M = pq
-TUPLE: bbs x n ;
-
-: generate-bbs-primes ( numbits -- p q )
- #! two primes congruent to 3 (mod 4)
- dup [ random-miller-rabin-prime==3(mod4) ] 2apply ;
-
-IN: crypto
-: make-bbs ( numbits -- blum-blum-shub )
- #! returns a Blum-Blum-Shub tuple
- generate-bbs-primes * [ find-relative-prime ] keep <bbs> ;
-
-IN: crypto-internals
-SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global
-
-: next-bbs-bit ( bbs -- bit )
- #! x = x^2 mod n, return low bit of calculated x
- [ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep
- [ set-bbs-x ] keep bbs-x 1 bitand ;
-
-SYMBOL: temp-bbs
-: (bbs-bits) ( numbits bbs -- n )
- temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ;
-
-IN: crypto
-: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ;
-: random-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ;
-: random-bytes ( numbits -- n ) 8 * random-bits ;
-: random ( n -- n )
- ! #! Cryptographically secure random number using Blum-Blum-Shub 256
- [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
-
From cd4f2028cda71711f1733ce4b5395b816968c625 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:19:37 -0500
Subject: [PATCH 107/197] random-256 -> 256 random-bits
---
extra/channels/remote/remote.factor | 2 +-
extra/concurrency/messaging/messaging.factor | 2 +-
extra/http/server/auth/providers/providers.factor | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor
index 2d8d003b8d..c9cfc83d27 100755
--- a/extra/channels/remote/remote.factor
+++ b/extra/channels/remote/remote.factor
@@ -14,7 +14,7 @@ IN: channels.remote
PRIVATE>
: publish ( channel -- id )
- random-256 dup >r remote-channels set-at r> ;
+ 256 random-bits dup >r remote-channels set-at r> ;
: get-channel ( id -- channel )
remote-channels at ;
diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor
index cfa2aea30d..e566a83fdf 100755
--- a/extra/concurrency/messaging/messaging.factor
+++ b/extra/concurrency/messaging/messaging.factor
@@ -40,7 +40,7 @@ M: thread send ( message thread -- )
TUPLE: synchronous data sender tag ;
: <synchronous> ( data -- sync )
- self random-256 synchronous construct-boa ;
+ self 256 random-bits synchronous construct-boa ;
TUPLE: reply data tag ;
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index d51679016e..cdad4815a6 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -27,7 +27,7 @@ GENERIC: new-user ( user provider -- user/f )
user email>> length 0 > [
user email>> email = [
user
- random-256 >hex >>ticket
+ 256 random-bits >hex >>ticket
dup provider update-user
] [ f ] if
] [ f ] if
From 274c7d8cad43f5110d0097df0de9ae1940378ac7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:19:54 -0500
Subject: [PATCH 108/197] 256 random-bits
---
extra/assocs/lib/lib.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 2500940373..b23ee1f830 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -41,7 +41,7 @@ IN: assocs.lib
>r 2array flip r> assoc-like ;
: generate-key ( assoc -- str )
- >r random-256 >hex r>
+ >r 256 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
From 077df62492d509a192824ec8210bebd28f65ab91 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:20:14 -0500
Subject: [PATCH 109/197] add 2bi*
---
extra/combinators/cleave/cleave.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index 049c8bf2a9..9bfbcd6759 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -54,6 +54,8 @@ MACRO: 2cleave ( seq -- )
: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
+: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline
+
: tri* ( x y z p q r -- p(x) q(y) r(z) )
>r rot >r bi* r> r> call ; inline
From 1802e7c443a85ff86cc831ad41e4b29d73508600 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 16:22:06 -0500
Subject: [PATCH 110/197] add random bootstrap
---
extra/bootstrap/random/random.factor | 8 ++++++++
1 file changed, 8 insertions(+)
create mode 100644 extra/bootstrap/random/random.factor
diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor
new file mode 100644
index 0000000000..7132860e1c
--- /dev/null
+++ b/extra/bootstrap/random/random.factor
@@ -0,0 +1,8 @@
+USING: vocabs.loader sequences system ;
+
+"random.mersenne-twister" require
+
+{
+ { [ windows? ] [ "random.windows" require ] }
+ { [ unix? ] [ "random.unix" require ] }
+} cond
From 3e7940216ec1e456e5ff76321c4fbd6f00d10464 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 19:15:32 -0500
Subject: [PATCH 111/197] swap append to swap append refactoring path+ to
append-path swap path+ to prepend-path calendar gmt-offset to duration
---
extra/asn1/asn1.factor | 8 +-
extra/automata/automata.factor | 2 +-
extra/bitfields/bitfields.factor | 2 +-
.../bootstrap/image/download/download.factor | 2 +-
extra/bootstrap/ui/tools/tools.factor | 2 +-
extra/bootstrap/ui/ui.factor | 2 +-
extra/builder/builder.factor | 4 +-
extra/builder/release/release.factor | 2 +-
extra/calendar/backend/backend.factor | 2 +-
extra/calendar/calendar-tests.factor | 226 +++++++++---------
extra/calendar/calendar.factor | 29 ++-
extra/calendar/format/format-tests.factor | 6 +-
extra/calendar/format/format.factor | 36 +--
extra/calendar/unix/unix.factor | 11 +-
extra/cocoa/messages/messages.factor | 4 +-
extra/combinators/cleave/cleave.factor | 2 +-
extra/combinators/lib/lib.factor | 8 +-
extra/core-foundation/core-foundation.factor | 2 +-
extra/cpu/8080/emulator/emulator.factor | 30 +--
extra/db/sqlite/sqlite.factor | 4 +-
extra/db/types/types.factor | 2 +-
extra/documents/documents.factor | 2 +-
extra/editors/editpadpro/editpadpro.factor | 2 +-
extra/editors/editplus/editplus.factor | 2 +-
extra/editors/emeditor/emeditor.factor | 2 +-
extra/editors/gvim/windows/windows.factor | 2 +-
extra/editors/jedit/jedit.factor | 4 +-
extra/editors/notepadpp/notepadpp.factor | 2 +-
extra/editors/scite/scite.factor | 2 +-
extra/editors/ted-notepad/ted-notepad.factor | 2 +-
extra/editors/ultraedit/ultraedit.factor | 2 +-
extra/editors/wordpad/wordpad.factor | 2 +-
extra/faq/faq.factor | 2 +-
extra/help/help.factor | 2 +-
extra/html/elements/elements.factor | 6 +-
extra/http/client/client.factor | 2 +-
.../http/server/actions/actions-tests.factor | 4 +-
extra/http/server/actions/actions.factor | 4 +-
.../http/server/components/components.factor | 2 +-
extra/http/server/static/static.factor | 4 +-
.../templating/fhtml/fhtml-tests.factor | 2 +-
.../http/server/validators/validators.factor | 2 +-
extra/io/encodings/utf16/utf16.factor | 4 +-
extra/io/files/unique/unique.factor | 4 +-
extra/io/paths/paths.factor | 2 +-
extra/io/windows/nt/files/files.factor | 8 +-
extra/io/windows/nt/nt-tests.factor | 6 +-
extra/koszul/koszul.factor | 6 +-
extra/locals/locals.factor | 2 +-
extra/logging/server/server.factor | 4 +-
extra/math/haar/haar.factor | 2 +-
extra/new-slots/new-slots.factor | 4 +-
extra/optimizer/debugger/debugger.factor | 2 +-
extra/project-euler/002/002.factor | 2 +-
extra/project-euler/035/035.factor | 2 +-
extra/project-euler/project-euler.factor | 4 +-
extra/smtp/smtp.factor | 8 +-
extra/strings/lib/lib.factor | 2 +-
extra/tar/tar.factor | 12 +-
extra/tools/deploy/backend/backend.factor | 4 +-
extra/tools/deploy/config/config.factor | 2 +-
extra/tools/deploy/macosx/macosx.factor | 12 +-
extra/tools/deploy/windows/windows.factor | 4 +-
extra/tools/vocabs/browser/browser.factor | 4 +-
extra/tools/vocabs/vocabs.factor | 18 +-
extra/tuple-arrays/tuple-arrays.factor | 2 +-
extra/ui/gadgets/lists/lists.factor | 2 +-
extra/wrap/wrap.factor | 2 +-
extra/xmode/catalog/catalog.factor | 4 +-
69 files changed, 290 insertions(+), 278 deletions(-)
diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor
index 99d1e0a19d..8954ffd8cc 100644
--- a/extra/asn1/asn1.factor
+++ b/extra/asn1/asn1.factor
@@ -135,18 +135,18 @@ SYMBOL: end
GENERIC: >ber ( obj -- byte-array )
M: fixnum >ber ( n -- byte-array )
>128-ber dup length 2 swap 2array
- "cc" pack-native swap append ;
+ "cc" pack-native prepend ;
: >ber-enumerated ( n -- byte-array )
>128-ber >byte-array dup length 10 swap 2array
- "CC" pack-native swap append ;
+ "CC" pack-native prepend ;
: >ber-length-encoding ( n -- byte-array )
dup 127 <= [
1array "C" pack-be
] [
1array "I" pack-be 0 swap remove dup length
- HEX: 80 + 1array "C" pack-be swap append
+ HEX: 80 + 1array "C" pack-be prepend
] if ;
! =========================================================
@@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array )
dup 126 > [
"range error in bignum" throw
] [
- 2 swap 2array "CC" pack-native swap append
+ 2 swap 2array "CC" pack-native prepend
] if ;
! =========================================================
diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor
index cd799d477e..b6d4152d0e 100644
--- a/extra/automata/automata.factor
+++ b/extra/automata/automata.factor
@@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
-: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
+: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
dup peek 1array swap dup first 1array append append ;
diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor
index 211ab28c92..175f66f4a6 100644
--- a/extra/bitfields/bitfields.factor
+++ b/extra/bitfields/bitfields.factor
@@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ;
>r keys r> define-slots ;
: define-setters ( classname slots -- )
- >r "with-" swap append r>
+ >r "with-" prepend r>
dup values [setters]
>r keys r> define-slots ;
diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor
index df559f49da..a186954ef0 100644
--- a/extra/bootstrap/image/download/download.factor
+++ b/extra/bootstrap/image/download/download.factor
@@ -18,7 +18,7 @@ bootstrap.image sequences io ;
: download-image ( arch -- )
boot-image-name dup need-new-image? [
"Downloading " write dup write "..." print
- url swap append download
+ url prepend download
] [
"Boot image up to date" print
drop
diff --git a/extra/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor
index c4a555b3e2..a3d02a0016 100755
--- a/extra/bootstrap/ui/tools/tools.factor
+++ b/extra/bootstrap/ui/tools/tools.factor
@@ -1,7 +1,7 @@
USING: kernel vocabs vocabs.loader sequences system ;
{ "ui" "help" "tools" }
-[ "bootstrap." swap append vocab ] all? [
+[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
"ui.cocoa" vocab [
diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor
index 86538e0000..f8db831dbc 100644
--- a/extra/bootstrap/ui/ui.factor
+++ b/extra/bootstrap/ui/ui.factor
@@ -8,7 +8,7 @@ vocabs vocabs.loader ;
{ [ windows? ] [ "windows" ] }
{ [ unix? ] [ "x11" ] }
} cond
- ] unless* "ui." swap append require
+ ] unless* "ui." prepend require
"ui.freetype" require
] when
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 7d95ce2409..ea404d6efa 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -58,8 +58,8 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
- builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
- builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
+ builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
+ builds "factor" append-path my-boot-image-name append-path "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor
index f0cf0ee113..0e26abe02f 100644
--- a/extra/builder/release/release.factor
+++ b/extra/builder/release/release.factor
@@ -8,7 +8,7 @@ IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path )
- builds "releases" path+
+ builds "releases" append-path
dup exists? not
[ dup make-directory ]
when ;
diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor
index 15b5e7cb8d..01c36c65ae 100644
--- a/extra/calendar/backend/backend.factor
+++ b/extra/calendar/backend/backend.factor
@@ -2,4 +2,4 @@ USING: kernel ;
IN: calendar.backend
SYMBOL: calendar-backend
-HOOK: gmt-offset calendar-backend
+HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )
diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor
index 1041c79691..e49d3ad894 100755
--- a/extra/calendar/calendar-tests.factor
+++ b/extra/calendar/calendar-tests.factor
@@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test
continuations system ;
IN: calendar.tests
-[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 -2 9 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 0 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 24 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 60 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
[ t ] [ now valid-timestamp? ] unit-test
[ f ] [ 1900 leap-year? ] unit-test
@@ -18,126 +18,126 @@ IN: calendar.tests
[ f ] [ 2001 leap-year? ] unit-test
[ f ] [ 2006 leap-year? ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
- 2006 10 10 0 0 1 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
- 2006 10 10 0 1 40 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
- 2006 10 9 23 58 20 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
- 2006 10 11 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 1 seconds time+
+ 2006 10 10 0 0 1 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 100 seconds time+
+ 2006 10 10 0 1 40 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 seconds time+
+ 2006 10 9 23 58 20 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 86400 seconds time+
+ 2006 10 11 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
- 2006 10 10 0 10 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
- 2006 10 10 0 10 30 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
- 2006 10 10 0 0 45 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
- 2006 10 9 23 59 15 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
+ 2006 10 10 0 10 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
+ 2006 10 10 0 10 30 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
+ 2006 10 10 0 0 45 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
+ 2006 10 9 23 59 15 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
- 2006 10 15 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
- 2006 10 9 23 50 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
- 2006 10 9 22 20 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 7200 minutes time+
+ 2006 10 15 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -10 minutes time+
+ 2006 10 9 23 50 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 minutes time+
+ 2006 10 9 22 20 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
- 2006 1 1 1 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
- 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
- 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
- 2006 1 1 12 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
- 2006 1 4 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 hours time+
+ 2006 1 1 1 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 hours time+
+ 2006 1 2 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 hours time+
+ 2005 12 31 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 hours time+
+ 2006 1 1 12 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 72 hours time+
+ 2006 1 4 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
- 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
- 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
- 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
- 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
- 2004 12 31 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
- 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 days time+
+ 2006 1 2 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 days time+
+ 2005 12 31 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 365 days time+
+ 2007 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -365 days time+
+ 2005 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 365 days time+
+ 2004 12 31 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 366 days time+
+ 2005 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
- 2006 12 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
- 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
- 2008 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
- 2007 2 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
- 2006 2 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
- 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
- 2005 12 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
- 2005 11 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
- 2004 12 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
- 2004 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
- 2005 3 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
- 2003 3 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 11 months time+
+ 2006 12 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 months time+
+ 2007 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 months time+
+ 2008 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 13 months time+
+ 2007 2 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 months time+
+ 2006 2 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 months time+
+ 2006 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 months time+
+ 2005 12 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -2 months time+
+ 2005 11 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -13 months time+
+ 2004 12 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 months time+
+ 2004 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 2 29 0 0 0 instant <timestamp> 12 months time+
+ 2005 3 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 2 29 0 0 0 instant <timestamp> -12 months time+
+ 2003 3 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
- 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
- 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
- 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
- 1906 1 1 0 0 0 0 <timestamp> = ] unit-test
-! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
-! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 years time+
+ 2006 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 years time+
+ 2007 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 years time+
+ 2005 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -100 years time+
+ 1906 1 1 0 0 0 instant <timestamp> = ] unit-test
+! [ t ] [ 2004 2 29 0 0 0 instant <timestamp> -1 years time+
+! 2003 2 28 0 0 0 instant <timestamp> = ] unit-test
-[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
+[ 5 ] [ 2006 7 14 0 0 0 instant <timestamp> day-of-week ] unit-test
-[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant <timestamp> ] 3keep 0 0 0 instant <timestamp> = ] unit-test
-[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 1 ] [ 2006 1 1 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2004 2 29 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 61 ] [ 2004 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 366 ] [ 2004 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 365 ] [ 2003 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2003 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
-[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
- 2009 1 1 0 0 10 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
- 1998 12 31 23 59 50 0 <timestamp> = ] unit-test
+[ t ] [ 2004 12 31 0 0 0 instant <timestamp> dup = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 10 seconds 5 years time+ time+
+ 2009 1 1 0 0 10 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> -10 seconds -5 years time+ time+
+ 1998 12 31 23 59 50 instant <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
- 2004 1 1 11 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
- 2004 1 1 16 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
- 2004 1 1 13 30 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 23 0 0 12 hours <timestamp> >gmt
+ 2004 1 1 11 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 5 0 0 -11 hours <timestamp> >gmt
+ 2004 1 1 16 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
+ 2004 1 1 13 30 0 instant <timestamp> = ] unit-test
-[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
- 2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
+[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
+ 2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
-[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
- 2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
+[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
+ 2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
-[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
- 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
+ 2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
-[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
- 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
+ 2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 2b80a8dce6..457b0bea11 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -3,20 +3,23 @@
USING: arrays kernel math math.functions namespaces sequences
strings tuples system vocabs.loader calendar.backend threads
-new-slots accessors combinators ;
+new-slots accessors combinators locals ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
C: <timestamp> timestamp
-: <date> ( year month day -- timestamp )
- 0 0 0 gmt-offset <timestamp> ;
-
TUPLE: duration year month day hour minute second ;
C: <duration> duration
+: gmt-offset-duration ( -- duration )
+ 0 0 0 gmt-offset <duration> ;
+
+: <date> ( year month day -- timestamp )
+ 0 0 0 gmt-offset-duration <timestamp> ;
+
: month-names
{
"Not a month" "January" "February" "March" "April" "May" "June"
@@ -226,16 +229,18 @@ M: duration <=> [ dt>years ] compare ;
: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
-: convert-timezone ( timestamp n -- timestamp )
+GENERIC: time- ( time1 time2 -- time )
+
+: convert-timezone ( timestamp duration -- timestamp )
over gmt-offset>> over = [ drop ] [
- [ over gmt-offset>> - hours time+ ] keep >>gmt-offset
+ [ over gmt-offset>> time- time+ ] keep >>gmt-offset
] if ;
: >local-time ( timestamp -- timestamp )
- gmt-offset convert-timezone ;
+ gmt-offset-duration convert-timezone ;
: >gmt ( timestamp -- timestamp )
- 0 convert-timezone ;
+ instant convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
@@ -245,8 +250,6 @@ M: timestamp <=> ( ts1 ts2 -- n )
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
-GENERIC: time- ( time1 time2 -- time )
-
M: timestamp time-
#! Exact calendar-time difference
(time-) seconds ;
@@ -263,14 +266,14 @@ M: timestamp time-
M: duration time-
before time+ ;
-: <zero> 0 0 0 0 0 0 0 <timestamp> ;
+: <zero> 0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
- clone 0 >>gmt-offset
+ clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
: unix-1970 ( -- timestamp )
- 1970 1 1 0 0 0 0 <timestamp> ; foldable
+ 1970 1 1 0 0 0 instant <timestamp> ; foldable
: millis>timestamp ( n -- timestamp )
>r unix-1970 r> milliseconds time+ ;
diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor
index eb32ce5b43..88bd0733c0 100755
--- a/extra/calendar/format/format-tests.factor
+++ b/extra/calendar/format/format-tests.factor
@@ -1,5 +1,6 @@
+USING: calendar.format calendar kernel tools.test
+io.streams.string ;
IN: calendar.format.tests
-USING: calendar.format tools.test io.streams.string ;
[ 0 ] [
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
@@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ;
[ 1+1/2 ] [
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
+
+[ ] [ now timestamp>rfc3339 drop ] unit-test
+[ ] [ now timestamp>rfc822 drop ] unit-test
diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor
index 89e09e0d0c..0ac0ebb2c3 100755
--- a/extra/calendar/format/format.factor
+++ b/extra/calendar/format/format.factor
@@ -1,6 +1,7 @@
-IN: calendar.format
USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators accessors ;
+accessors arrays io.streams.string combinators accessors
+combinators.cleave ;
+IN: calendar.format
GENERIC: day. ( obj -- )
@@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- )
: timestamp>string ( timestamp -- str )
[ (timestamp>string) ] with-string-writer ;
-: (write-gmt-offset) ( ratio -- )
- 1 /mod swap write-00 60 * write-00 ;
+: (write-gmt-offset) ( duration -- )
+ [ hour>> write-00 ] [ minute>> write-00 ] bi ;
: write-gmt-offset ( gmt-offset -- )
- {
- { [ dup zero? ] [ drop "GMT" write ] }
- { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
- { [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
+ dup instant <=> {
+ { [ dup 0 = ] [ 2drop "GMT" write ] }
+ { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
+ { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
} cond ;
-: timestamp>rfc822-string ( timestamp -- str )
+: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
[
@@ -76,14 +77,19 @@ M: timestamp year. ( timestamp -- )
: timestamp>http-string ( timestamp -- str )
#! http timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
- >gmt timestamp>rfc822-string ;
+ >gmt timestamp>rfc822 ;
-: write-rfc3339-gmt-offset ( n -- )
- dup zero? [ drop "Z" write ] [
- dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
- 60 * 60 /mod swap write-00 CHAR: : write1 write-00
- ] if ;
+: (write-rfc3339-gmt-offset) ( duration -- )
+ [ hour>> write-00 CHAR: : write1 ]
+ [ minute>> write-00 ] bi ;
+: write-rfc3339-gmt-offset ( duration -- )
+ dup instant <=> {
+ { [ dup 0 = ] [ 2drop "Z" write ] }
+ { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
+ { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
+ } cond ;
+
: (timestamp>rfc3339) ( timestamp -- )
dup year>> number>string write CHAR: - write1
dup month>> write-00 CHAR: - write1
diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor
index 30e22c487b..2877fa07b5 100644
--- a/extra/calendar/unix/unix.factor
+++ b/extra/calendar/unix/unix.factor
@@ -1,6 +1,5 @@
-
USING: alien alien.c-types arrays calendar.backend
- kernel structs math unix.time namespaces ;
+kernel structs math unix.time namespaces ;
IN: calendar.unix
@@ -8,11 +7,11 @@ TUPLE: unix-calendar ;
T{ unix-calendar } calendar-backend set-global
-: get-time
+: get-time ( -- alien )
f time <uint> localtime ;
-: timezone-name
+: timezone-name ( -- string )
get-time tm-zone ;
-M: unix-calendar gmt-offset
- get-time tm-gmtoff 3600 / ;
+M: unix-calendar gmt-offset ( -- hours minutes seconds )
+ get-time tm-gmtoff 3600 /mod 60 /mod ;
diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor
index e2072f441c..480e19b005 100755
--- a/extra/cocoa/messages/messages.factor
+++ b/extra/cocoa/messages/messages.factor
@@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at
: lookup-method ( selector -- method )
dup objc-methods get at
- [ ] [ "No such method: " swap append throw ] ?if ;
+ [ ] [ "No such method: " prepend throw ] ?if ;
: make-dip ( quot n -- quot' )
dup
@@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot )
! Runtime introspection
: (objc-class) ( string word -- class )
dupd execute
- [ ] [ "No such class: " swap append throw ] ?if ; inline
+ [ ] [ "No such class: " prepend throw ] ?if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index 9bfbcd6759..1bc7480198 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -70,7 +70,7 @@ MACRO: spread ( seq -- )
dup
[ drop [ >r ] ] map concat
swap
- [ [ r> ] swap append ] map concat
+ [ [ r> ] prepend ] map concat
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 07a9a6d43d..459938c885 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -75,11 +75,11 @@ MACRO: && ( quots -- ? )
[ [ not ] append [ f ] ] t short-circuit ;
MACRO: <-&& ( quots -- )
- [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
+ [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
[ nip ] append ;
MACRO: <--&& ( quots -- )
- [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
+ [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ;
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
@@ -130,12 +130,12 @@ MACRO: map-call-with ( quots -- )
[ (make-call-with) ] keep length [ narray ] curry compose ;
: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+ [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
[ 2drop ] append ;
MACRO: map-call-with2 ( quots -- )
[
- [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+ [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
[ 2drop ] append
] keep length [ narray ] curry append ;
diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor
index 297e4aec87..73b8fce229 100644
--- a/extra/core-foundation/core-foundation.factor
+++ b/extra/core-foundation/core-foundation.factor
@@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ;
dup <CFBundle> [
CFBundleLoadExecutable drop
] [
- "Cannot load bundled named " swap append throw
+ "Cannot load bundled named " prepend throw
] ?if ;
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor
index 24eceee744..d4574119b2 100755
--- a/extra/cpu/8080/emulator/emulator.factor
+++ b/extra/cpu/8080/emulator/emulator.factor
@@ -446,7 +446,7 @@ M: cpu reset ( cpu -- )
SYMBOL: rom-root
: rom-dir ( -- string )
- rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
+ rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
: load-rom* ( seq cpu -- )
#! 'seq' is an array of arrays. Each array contains
@@ -455,7 +455,7 @@ SYMBOL: rom-root
#! file path shoul dbe relative to the '/roms' resource path.
rom-dir [
cpu-ram [
- swap first2 rom-dir swap path+ binary [
+ swap first2 rom-dir prepend-path binary [
swap (load-rom)
] with-file-reader
] curry each
@@ -1027,14 +1027,14 @@ SYMBOL: $4
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: ADC-R,(RR)-instruction ( -- parser )
"ADC-R,(RR)" "ADC" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: SBC-R,N-instruction ( -- parser )
"SBC-R,N" "SBC" complex-instruction
@@ -1047,14 +1047,14 @@ SYMBOL: $4
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: SBC-R,(RR)-instruction ( -- parser )
"SBC-R,(RR)" "SBC" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: SUB-R-instruction ( -- parser )
"SUB-R" "SUB" complex-instruction
@@ -1082,21 +1082,21 @@ SYMBOL: $4
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: ADD-RR,RR-instruction ( -- parser )
"ADD-RR,RR" "ADD" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: ADD-R,(RR)-instruction ( -- parser )
"ADD-R,(RR)" "ADD" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-RR,NN-instruction
#! LD BC,nn
@@ -1124,28 +1124,28 @@ SYMBOL: $4
16-bit-registers indirect sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-R,R-instruction
"LD-R,R" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-RR,RR-instruction
"LD-RR,RR" "LD" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-R,(RR)-instruction
"LD-R,(RR)" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-(NN),RR-instruction
"LD-(NN),RR" "LD" complex-instruction
@@ -1194,14 +1194,14 @@ SYMBOL: $4
16-bit-registers indirect sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: EX-RR,RR-instruction
"EX-RR,RR" "EX" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: 8080-generator-parser
NOP-instruction
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index bca904279b..d7d954c0dc 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -71,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[
- [ sql-spec-column-name ":" swap append ]
+ [ sql-spec-column-name ":" prepend ]
[ sql-spec-slot-name rot get-slot-named ]
[ sql-spec-type ] tri 3array
] with map
@@ -173,7 +173,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- )
- dup 1, sql-spec-column-name ":" swap append 0% ;
+ dup 1, sql-spec-column-name ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index a0414f334d..94a8d6f392 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -127,7 +127,7 @@ TUPLE: no-sql-modifier ;
: modifiers ( spec -- str )
sql-spec-modifiers
[ lookup-modifier ] map " " join
- dup empty? [ " " swap append ] unless ;
+ dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- )
diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor
index 993e69ec14..60ae592d4c 100755
--- a/extra/documents/documents.factor
+++ b/extra/documents/documents.factor
@@ -74,7 +74,7 @@ TUPLE: document locs ;
0 swap [ append ] change-nth ;
: append-last ( str seq -- )
- [ length 1- ] keep [ swap append ] change-nth ;
+ [ length 1- ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
>r first2 swap r> nth swap ;
diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor
index eb31b2aa47..9da57e16bf 100755
--- a/extra/editors/editpadpro/editpadpro.factor
+++ b/extra/editors/editpadpro/editpadpro.factor
@@ -5,7 +5,7 @@ IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
- program-files "JGsoft" path+
+ program-files "JGsoft" append-path
t [ >lower "editpadpro.exe" tail? ] find-file
] unless* ;
diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor
index ee24c99463..363d202f6c 100755
--- a/extra/editors/editplus/editplus.factor
+++ b/extra/editors/editplus/editplus.factor
@@ -4,7 +4,7 @@ IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
- program-files "\\EditPlus 2\\editplus.exe" path+
+ program-files "\\EditPlus 2\\editplus.exe" append-path
] unless* ;
: editplus ( file line -- )
diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor
index bed333694c..8aecb49ae5 100755
--- a/extra/editors/emeditor/emeditor.factor
+++ b/extra/editors/emeditor/emeditor.factor
@@ -4,7 +4,7 @@ IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
- program-files "\\EmEditor\\EmEditor.exe" path+
+ program-files "\\EmEditor\\EmEditor.exe" append-path
] unless* ;
: emeditor ( file line -- )
diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor
index 030c968e81..489000498e 100755
--- a/extra/editors/gvim/windows/windows.factor
+++ b/extra/editors/gvim/windows/windows.factor
@@ -4,6 +4,6 @@ IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
- program-files "vim" path+
+ program-files "vim" append-path
t [ "gvim.exe" tail? ] find-file
] unless* ;
diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor
index 3ce2c40192..7b6066df7c 100644
--- a/extra/editors/jedit/jedit.factor
+++ b/extra/editors/jedit/jedit.factor
@@ -8,7 +8,7 @@ io.encodings.utf8 ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
- home "/.jedit/server" path+ ascii [
+ home "/.jedit/server" append-path ascii [
readln drop
readln string>number
readln string>number
@@ -32,7 +32,7 @@ IN: editors.jedit
] with-stream ;
: jedit-location ( file line -- )
- number>string "+line:" swap append 2array
+ number>string "+line:" prepend 2array
make-jedit-request send-jedit-request ;
: jedit-file ( file -- )
diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor
index 72ac6c72d7..959e633cc3 100755
--- a/extra/editors/notepadpp/notepadpp.factor
+++ b/extra/editors/notepadpp/notepadpp.factor
@@ -4,7 +4,7 @@ IN: editors.notepadpp
: notepadpp-path
\ notepadpp-path get-global [
- program-files "notepad++\\notepad++.exe" path+
+ program-files "notepad++\\notepad++.exe" append-path
] unless* ;
: notepadpp ( file line -- )
diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor
index ac9a032abc..a0bacaabba 100755
--- a/extra/editors/scite/scite.factor
+++ b/extra/editors/scite/scite.factor
@@ -14,7 +14,7 @@ IN: editors.scite
: scite-path ( -- path )
\ scite-path get-global [
- program-files "wscite\\SciTE.exe" path+
+ program-files "wscite\\SciTE.exe" append-path
] unless* ;
: scite-command ( file line -- cmd )
diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor
index 5d58e182a3..9b341dd2a8 100755
--- a/extra/editors/ted-notepad/ted-notepad.factor
+++ b/extra/editors/ted-notepad/ted-notepad.factor
@@ -4,7 +4,7 @@ IN: editors.ted-notepad
: ted-notepad-path
\ ted-notepad-path get-global [
- program-files "\\TED Notepad\\TedNPad.exe" path+
+ program-files "\\TED Notepad\\TedNPad.exe" append-path
] unless* ;
: ted-notepad ( file line -- )
diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor
index f9d27174b3..1fef9f3350 100755
--- a/extra/editors/ultraedit/ultraedit.factor
+++ b/extra/editors/ultraedit/ultraedit.factor
@@ -5,7 +5,7 @@ IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
program-files
- "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
+ "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
] unless* ;
: ultraedit ( file line -- )
diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor
index 5ad08b613b..d1f979e0f3 100755
--- a/extra/editors/wordpad/wordpad.factor
+++ b/extra/editors/wordpad/wordpad.factor
@@ -5,7 +5,7 @@ IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
- program-files "\\Windows NT\\Accessories\\wordpad.exe" path+
+ program-files "\\Windows NT\\Accessories\\wordpad.exe" append-path
] unless* ;
: wordpad ( file line -- )
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
index 7ad3900163..d7624466f7 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -79,7 +79,7 @@ C: <faq> faq
"br" contained, nl, ;
: toc-link, ( question-list number -- )
- number>string "#" swap append "href" swap 2array 1array
+ number>string "#" prepend "href" swap 2array 1array
"a" swap [ question-list-title , ] tag*, br, ;
: toc, ( faq -- )
diff --git a/extra/help/help.factor b/extra/help/help.factor
index 34e90b2ccf..4cb8cfe854 100755
--- a/extra/help/help.factor
+++ b/extra/help/help.factor
@@ -98,7 +98,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
: about ( vocab -- )
dup require
dup vocab [ ] [
- "No such vocabulary: " swap append throw
+ "No such vocabulary: " prepend throw
] ?if
dup vocab-help [
help
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index 286037d4dc..754afb1ea7 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -38,7 +38,7 @@ IN: html.elements
! <a =href a> "Click me" write </a>
!
! (url -- )
-! <a "http://" swap append =href a> "click" write </a>
+! <a "http://" prepend =href a> "click" write </a>
!
! (url -- )
! <a [ "http://" % % ] "" make =href a> "click" write </a>
@@ -72,7 +72,7 @@ SYMBOL: html
dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
-: <foo "<" swap append ;
+: <foo "<" prepend ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
@@ -134,7 +134,7 @@ SYMBOL: html
: attribute-effect T{ effect f { "string" } 0 } ;
: define-attribute-word ( name -- )
- dup "=" swap append swap
+ dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
[
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 6d875ef560..fc85cce3ad 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -12,7 +12,7 @@ DEFER: http-request
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
- "/" split1 [ "/" swap append ] [ "/" ] if*
+ "/" split1 [ "/" prepend ] [ "/" ] if*
swap parse-host ;
: store-path ( request path -- request )
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
index c604b8a427..ebf8e8770b 100755
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -27,8 +27,8 @@ blah
] unit-test
<action>
- [ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
- { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
+ [ +append-path get "xxx" get "X" <repetition> concat append ] >>submit
+ { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 52567ed352..287f6dd907 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations locals ;
IN: http.server.actions
-SYMBOL: +path+
+SYMBOL: +append-path
SYMBOL: params
@@ -40,7 +40,7 @@ TUPLE: action init display submit get-params post-params ;
M: action call-responder ( path action -- response )
'[
, ,
- [ +path+ associate request-params union params set ]
+ [ +append-path associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index 02c992651a..8581335f3d 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -13,7 +13,7 @@ TUPLE: component id required default ;
: component ( name -- component )
dup components get at
- [ ] [ "No such component: " swap append throw ] ?if ;
+ [ ] [ "No such component: " prepend throw ] ?if ;
GENERIC: validate* ( value component -- result )
GENERIC: render-view* ( value component -- )
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index b408b1b6b0..b001242776 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -39,7 +39,7 @@ TUPLE: file-responder root hook special ;
[ 2drop <304> ] [ file-responder get hook>> call ] if ;
: serving-path ( filename -- filename )
- "" or file-responder get root>> swap path+ ;
+ "" or file-responder get root>> prepend-path ;
: serve-file ( filename -- response )
dup mime-type
@@ -68,7 +68,7 @@ TUPLE: file-responder root hook special ;
swap '[ , directory. ] >>body ;
: find-index ( filename -- path )
- { "index.html" "index.fhtml" } [ path+ ] with map
+ { "index.html" "index.fhtml" } [ append-path ] with map
[ exists? ] find nip ;
: serve-directory ( filename -- response )
diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor
index 9774e4c1f2..2e253d9132 100755
--- a/extra/http/server/templating/fhtml/fhtml-tests.factor
+++ b/extra/http/server/templating/fhtml/fhtml-tests.factor
@@ -5,7 +5,7 @@ IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"resource:extra/http/server/templating/fhtml/test/"
- swap append
+ prepend
[
".fhtml" append [ run-template ] with-string-writer
] keep
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
index 539a58d19f..f2d1f568e6 100755
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -59,7 +59,7 @@ C: <validation-error> validation-error
: v-regexp ( str what regexp -- str )
>r over r> matches?
- [ drop ] [ "invalid " swap append throw ] if ;
+ [ drop ] [ "invalid " prepend throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor
index 290761ec91..05dc7235f6 100755
--- a/extra/io/encodings/utf16/utf16.factor
+++ b/extra/io/encodings/utf16/utf16.factor
@@ -18,13 +18,13 @@ TUPLE: utf16 ;
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
: double-be ( stream byte -- stream char )
- over stream-read1 swap append-nums ;
+ over stream-read1 prepend-nums ;
: quad-be ( stream byte -- stream char )
double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
- over stream-read1 swap append-nums HEX: 10000 +
+ over stream-read1 prepend-nums HEX: 10000 +
] [ 2drop dup stream-read1 drop replacement-char ] if
] when* ;
diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor
index 1e77cd6814..9a271e402c 100644
--- a/extra/io/files/unique/unique.factor
+++ b/extra/io/files/unique/unique.factor
@@ -24,7 +24,7 @@ PRIVATE>
: make-unique-file ( prefix suffix -- path stream )
temporary-path -rot
[
- unique-length random-name swap 3append path+
+ unique-length random-name swap 3append append-path
dup (make-unique-file)
] 3curry unique-retries retry ;
@@ -36,7 +36,7 @@ PRIVATE>
: make-unique-directory ( -- path )
[
- temporary-path unique-length random-name path+
+ temporary-path unique-length random-name append-path
dup make-directory
] unique-retries retry ;
diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor
index 4acfb9acad..163194195d 100755
--- a/extra/io/paths/paths.factor
+++ b/extra/io/paths/paths.factor
@@ -5,7 +5,7 @@ IN: io.paths
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
- dup directory [ first2 >r path+ r> 2array ] with map ;
+ dup directory [ first2 >r append-path r> 2array ] with map ;
: push-directory ( path iter -- )
>r qualified-directory r> [
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index dda94da892..7cf056674f 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -32,9 +32,9 @@ M: windows-nt-io root-directory? ( path -- ? )
} && [ 2 head ] [ "Not an absolute path" throw ] if ;
: prepend-prefix ( string -- string' )
- unicode-prefix swap append ;
+ unicode-prefix prepend ;
-: windows-path+ ( cwd path -- newpath )
+: windows-append-path ( cwd path -- newpath )
{
! empty
{ [ dup empty? ] [ drop ] }
@@ -43,7 +43,7 @@ M: windows-nt-io root-directory? ( path -- ? )
! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ nip ] }
! ..\\foo
- { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] }
+ { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-append-path ] }
! .\\foo
{ [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] }
! \\foo
@@ -62,7 +62,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "Pathname must be a string" throw ] unless
dup empty? [ "Empty pathname" throw ] when
{ { CHAR: / CHAR: \\ } } substitute
- cwd swap windows-path+
+ cwd swap windows-append-path
[ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ;
diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor
index c4ac99fe4a..6353bfe86e 100755
--- a/extra/io/windows/nt/nt-tests.factor
+++ b/extra/io/windows/nt/nt-tests.factor
@@ -22,15 +22,15 @@ IN: io.windows.nt.tests
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
"C:\\builds\\factor\\12345\\"
- "..\\log.txt" windows-path+
+ "..\\log.txt" windows-append-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
- "..\\.." windows-path+
+ "..\\.." windows-append-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
- "..\\.." windows-path+
+ "..\\.." windows-append-path
] unit-test
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index 69de838eec..71cbb1d951 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -33,7 +33,7 @@ SYMBOL: terms
{
{ [ dup 1 = ] [ drop " + " ] }
{ [ dup -1 = ] [ drop " - " ] }
- { [ t ] [ number>string " + " swap append ] }
+ { [ t ] [ number>string " + " prepend ] }
} cond ;
: (alt.) ( basis n -- str )
@@ -155,7 +155,7 @@ DEFER: (d)
: (tensor) ( seq1 seq2 -- seq )
[
- [ swap append natural-sort ] curry map
+ [ prepend natural-sort ] curry map
] with map concat ;
: tensor ( graded-basis1 graded-basis2 -- bigraded-basis )
@@ -202,7 +202,7 @@ DEFER: (d)
: bigraded-betti ( u-generators z-generators -- seq )
[ basis graded ] 2apply tensor bigraded-ker/im-d
[ [ [ first ] map ] map ] keep
- [ [ second ] map 2 head* { 0 0 } swap append ] map
+ [ [ second ] map 2 head* { 0 0 } prepend ] map
1 tail dup first length 0 <array> add
[ v- ] 2map ;
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index a8f5e139e7..9f96a3444d 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -176,7 +176,7 @@ M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
dup free-vars [ <quote> ] map dup % [
- over block-vars swap append
+ over block-vars prepend
swap block-body [ [ lambda-rewrite* ] each ] [ ] make
swap point-free ,
] keep length \ curry <repetition> % ;
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index 372216c45e..bed6a2fec3 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -11,10 +11,10 @@ IN: logging.server
\ log-root get "logs" resource-path or ;
: log-path ( service -- path )
- log-root swap path+ ;
+ log-root prepend-path ;
: log# ( path n -- path' )
- number>string ".log" append path+ ;
+ number>string ".log" append append-path ;
SYMBOL: log-files
diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor
index 13eaa479a5..91d9fd8ece 100644
--- a/extra/math/haar/haar.factor
+++ b/extra/math/haar/haar.factor
@@ -12,4 +12,4 @@ IN: math.haar
2 group dup averages [ differences ] keep ;
: haar ( seq -- seq )
- dup length 1 <= [ haar-step haar swap append ] unless ;
+ dup length 1 <= [ haar-step haar prepend ] unless ;
diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor
index 3273036b8b..9773da7b41 100755
--- a/extra/new-slots/new-slots.factor
+++ b/extra/new-slots/new-slots.factor
@@ -27,7 +27,7 @@ IN: new-slots
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-word ( name -- word )
- ">>" swap append setter-effect create-accessor ;
+ ">>" prepend setter-effect create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
@@ -37,7 +37,7 @@ IN: new-slots
: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
: changer-word ( name -- word )
- "change-" swap append changer-effect create-accessor ;
+ "change-" prepend changer-effect create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor
index 3cbddf8296..1f5453798d 100755
--- a/extra/optimizer/debugger/debugger.factor
+++ b/extra/optimizer/debugger/debugger.factor
@@ -65,7 +65,7 @@ MATCH-VARS: ?a ?b ?c ;
M: #shuffle node>quot
dup node-in-d over node-out-d pretty-shuffle
[ , ] [ >r drop t r> ] if*
- dup effect-str "#shuffle: " swap append comment, ;
+ dup effect-str "#shuffle: " prepend comment, ;
: pushed-literals node-out-d [ value-literal literalize ] map ;
diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor
index 0b8f773887..b660ed0958 100644
--- a/extra/project-euler/002/002.factor
+++ b/extra/project-euler/002/002.factor
@@ -41,7 +41,7 @@ PRIVATE>
: fib-upto* ( n -- seq )
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
- 1 head-slice* { 0 1 } swap append ;
+ 1 head-slice* { 0 1 } prepend ;
: euler002a ( -- answer )
1000000 fib-upto* [ even? ] subset sum ;
diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor
index d8d38d1647..9873abf05c 100755
--- a/extra/project-euler/035/035.factor
+++ b/extra/project-euler/035/035.factor
@@ -34,7 +34,7 @@ IN: project-euler.035
] if ;
: rotate ( seq n -- seq )
- cut* swap append ;
+ cut* prepend ;
: (circular?) ( seq n -- ? )
dup 0 > [
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 25ddd9a60b..04339ad5b7 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -30,7 +30,7 @@ IN: project-euler
number>string 3 CHAR: 0 pad-left ;
: solution-path ( n -- str/f )
- number>euler "project-euler." swap append
+ number>euler "project-euler." prepend
vocab where dup [ first ?resource-path ] when ;
PRIVATE>
@@ -40,7 +40,7 @@ PRIVATE>
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
- dup number>euler "project-euler." swap append run
+ dup number>euler "project-euler." prepend run
"Answer: " swap dup number? [ number>string ] when append print
"Source: " swap solution-path append print
] [
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index a941b14a47..f7cdf9e64d 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -31,7 +31,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup "\r\n>" seq-intersect empty?
- [ "Bad e-mail address: " swap append throw ] unless ;
+ [ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- )
"MAIL FROM:<" write validate-address write ">" write crlf ;
@@ -89,7 +89,7 @@ LOG: smtp-response DEBUG
: validate-header ( string -- string' )
dup "\r\n" seq-intersect empty?
- [ "Invalid header string: " swap append throw ] unless ;
+ [ "Invalid header string: " prepend throw ] unless ;
: write-header ( key value -- )
swap
@@ -143,7 +143,7 @@ M: email clone
dup to>> ", " join "To" set-header
[ [ extract-email ] map ] change-to
dup subject>> "Subject" set-header
- now timestamp>rfc822-string "Date" set-header
+ now timestamp>rfc822 "Date" set-header
message-id "Message-Id" set-header ;
: <email> ( -- email )
@@ -164,7 +164,7 @@ M: email clone
! : (cram-md5-auth) ( -- response )
! swap challenge get
! string>md5-hmac hex-string
-! " " swap append append
+! " " prepend append
! >base64 ;
!
! : cram-md5-auth ( key login -- )
diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor
index 7f13cd58a9..c6299e6b08 100644
--- a/extra/strings/lib/lib.factor
+++ b/extra/strings/lib/lib.factor
@@ -7,7 +7,7 @@ IN: strings.lib
: >Upper ( str -- str )
dup empty? [
- unclip ch>upper 1string swap append
+ unclip ch>upper 1string prepend
] unless ;
: >Upper-dashes ( str -- str )
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index 06e9644370..d1c4b148a5 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -89,12 +89,12 @@ TUPLE: unimplemented-typeflag header ;
tar-header-typeflag
1string \ unimplemented-typeflag construct-boa ;
-: tar-path+ ( path -- newpath )
- base-dir get swap path+ ;
+: tar-append-path ( path -- newpath )
+ base-dir get prepend-path ;
! Normal file
: typeflag-0
- tar-header-name tar-path+ binary <file-writer>
+ tar-header-name tar-append-path binary <file-writer>
[ read-data-blocks ] keep dispose ;
! Hard link
@@ -115,7 +115,7 @@ TUPLE: unimplemented-typeflag header ;
! Directory
: typeflag-5 ( header -- )
- tar-header-name tar-path+ make-directories ;
+ tar-header-name tar-append-path make-directories ;
! FIFO
: typeflag-6 ( header -- )
@@ -166,7 +166,7 @@ TUPLE: unimplemented-typeflag header ;
<string-writer> [ read-data-blocks ] keep
>string [ zero? ] right-trim filename set
global [ "long filename: " write filename get . flush ] bind
- filename get tar-path+ make-directories ;
+ filename get tar-append-path make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- )
@@ -226,7 +226,7 @@ TUPLE: unimplemented-typeflag header ;
! drop
! ] [
! dup tar-header-name
- ! dup parent-dir base-dir swap path+
+ ! dup parent-dir base-dir prepend-path
! global [ dup [ . flush ] when* ] bind
! make-directories <file-writer>
! out-stream set
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 60dc11257f..2476077ba9 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -79,9 +79,9 @@ IN: tools.deploy.backend
"-run=tools.deploy.shaker" ,
- "-deploy-vocab=" swap append ,
+ "-deploy-vocab=" prepend ,
- "-output-image=" swap append ,
+ "-output-image=" prepend ,
strip-word-names? [ "-no-stack-traces" , ] when
] { } make
diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor
index 78f1d487de..c527cb945c 100755
--- a/extra/tools/deploy/config/config.factor
+++ b/extra/tools/deploy/config/config.factor
@@ -66,7 +66,7 @@ SYMBOL: deploy-image
} union ;
: deploy-config-path ( vocab -- string )
- vocab-dir "deploy.factor" path+ ;
+ vocab-dir "deploy.factor" append-path ;
: deploy-config ( vocab -- assoc )
dup default-config swap
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 6db19cf868..9fe35647fe 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -10,15 +10,15 @@ IN: tools.deploy.macosx
vm parent-directory parent-directory ;
: copy-bundle-dir ( bundle-name dir -- )
- bundle-dir over path+ -rot
- "Contents" swap path+ path+ copy-tree ;
+ bundle-dir over append-path -rot
+ "Contents" prepend-path append-path copy-tree ;
: copy-vm ( executable bundle-name -- vm )
- "Contents/MacOS/" path+ swap path+ vm over copy-file ;
+ "Contents/MacOS/" append-path prepend-path vm over copy-file ;
: copy-fonts ( name -- )
"fonts/" resource-path
- swap "Contents/Resources/" path+ copy-tree-into ;
+ swap "Contents/Resources/" append-path copy-tree-into ;
: app-plist ( executable bundle-name -- string )
[
@@ -30,12 +30,12 @@ IN: tools.deploy.macosx
file-name "CFBundleName" set
dup "CFBundleExecutable" set
- "org.factor." swap append "CFBundleIdentifier" set
+ "org.factor." prepend "CFBundleIdentifier" set
] H{ } make-assoc plist>string ;
: create-app-plist ( vocab bundle-name -- )
[ app-plist ] keep
- "Contents/Info.plist" path+
+ "Contents/Info.plist" append-path
utf8 set-file-contents ;
: create-app-dir ( vocab bundle-name -- vm )
diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 6a2ce448af..1c9a8195c5 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -6,7 +6,7 @@ prettyprint windows.shell32 windows.user32 ;
IN: tools.deploy.windows
: copy-vm ( executable bundle-name -- vm )
- swap path+ ".exe" append
+ prepend-path ".exe" append
vm over copy-file ;
: copy-fonts ( bundle-name -- )
@@ -23,7 +23,7 @@ IN: tools.deploy.windows
copy-vm ;
: image-name ( vocab bundle-name -- str )
- swap path+ ".image" append ;
+ prepend-path ".image" append ;
TUPLE: windows-deploy-implementation ;
diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor
index 06eba5f65c..69ad9272a7 100755
--- a/extra/tools/vocabs/browser/browser.factor
+++ b/extra/tools/vocabs/browser/browser.factor
@@ -31,7 +31,7 @@ IN: tools.vocabs.browser
] with-row ;
: root-heading. ( root -- )
- [ "Children from " swap append ] [ "Children" ] if*
+ [ "Children from " prepend ] [ "Children" ] if*
$heading ;
: vocabs. ( assoc -- )
@@ -195,7 +195,7 @@ M: vocab-tag summary article-title ;
M: vocab-author >link ;
M: vocab-author article-title
- vocab-author-name "Vocabularies by " swap append ;
+ vocab-author-name "Vocabularies by " prepend ;
M: vocab-author article-name vocab-author-name ;
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 2f2e834808..d7e1070666 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -7,15 +7,15 @@ io debugger continuations compiler.errors init io.crc32 ;
IN: tools.vocabs
: vocab-tests-file ( vocab -- path )
- dup "-tests.factor" vocab-dir+ vocab-path+ dup
+ dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup resource-exists? [ drop f ] unless ] [ drop f ] if ;
: vocab-tests-dir ( vocab -- paths )
- dup vocab-dir "tests" path+ vocab-path+ dup [
+ dup vocab-dir "tests" append-path vocab-append-path dup [
dup resource-exists? [
dup ?resource-path directory keys
[ ".factor" tail? ] subset
- [ path+ ] with map
+ [ append-path ] with map
] [ drop f ] if
] [ drop f ] if ;
@@ -103,10 +103,10 @@ MEMO: (vocab-file-contents) ( path -- lines )
[ utf8 file-lines ] [ drop f ] if ;
: vocab-file-contents ( vocab name -- seq )
- vocab-path+ dup [ (vocab-file-contents) ] when ;
+ vocab-append-path dup [ (vocab-file-contents) ] when ;
: set-vocab-file-contents ( seq vocab name -- )
- dupd vocab-path+ [
+ dupd vocab-append-path [
?resource-path utf8 set-file-lines
] [
"The " swap vocab-name
@@ -115,7 +115,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
] ?if ;
: vocab-summary-path ( vocab -- string )
- vocab-dir "summary.txt" path+ ;
+ vocab-dir "summary.txt" append-path ;
: vocab-summary ( vocab -- summary )
dup dup vocab-summary-path vocab-file-contents
@@ -141,7 +141,7 @@ M: vocab-link summary vocab-summary ;
set-vocab-file-contents ;
: vocab-tags-path ( vocab -- string )
- vocab-dir "tags.txt" path+ ;
+ vocab-dir "tags.txt" append-path ;
: vocab-tags ( vocab -- tags )
dup vocab-tags-path vocab-file-contents ;
@@ -153,7 +153,7 @@ M: vocab-link summary vocab-summary ;
[ vocab-tags append prune ] keep set-vocab-tags ;
: vocab-authors-path ( vocab -- string )
- vocab-dir "authors.txt" path+ ;
+ vocab-dir "authors.txt" append-path ;
: vocab-authors ( vocab -- authors )
dup vocab-authors-path vocab-file-contents ;
@@ -165,7 +165,7 @@ M: vocab-link summary vocab-summary ;
directory [ second ] subset keys natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
- [ vocab-dir path+ ?resource-path subdirs ] keep
+ [ vocab-dir append-path ?resource-path subdirs ] keep
dup empty? [
drop
] [
diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor
index 7a1df7ac1d..061deec6ec 100644
--- a/extra/tuple-arrays/tuple-arrays.factor
+++ b/extra/tuple-arrays/tuple-arrays.factor
@@ -15,7 +15,7 @@ TUPLE: tuple-array example ;
[ set-tuple-array-example ] keep ;
: reconstruct ( seq example -- tuple )
- swap append >tuple ;
+ prepend >tuple ;
M: tuple-array nth
[ delegate nth ] keep
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index 5fbe9ba0eb..3bac7969c5 100755
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -27,7 +27,7 @@ TUPLE: list index presenter color hook ;
swap set-list-index ;
: list-presentation-hook ( list -- quot )
- list-hook [ [ [ list? ] is? ] find-parent ] swap append ;
+ list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep <presentation>
diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor
index 41dea1bd13..a2ca25ce6e 100644
--- a/extra/wrap/wrap.factor
+++ b/extra/wrap/wrap.factor
@@ -29,4 +29,4 @@ SYMBOL: width
broken-lines "\n" join ;
: indented-break ( string width indent -- newstring )
- [ length - broken-lines ] keep [ swap append ] curry map "\n" join ;
+ [ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 6bff786fff..c7eaafe887 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -37,13 +37,13 @@ TAGS>
MEMO: (load-mode) ( name -- rule-sets )
modes at mode-file
- "extra/xmode/modes/" swap append
+ "extra/xmode/modes/" prepend
resource-path utf8 <file-reader> parse-mode ;
SYMBOL: rule-sets
: no-such-rule-set ( name -- * )
- "No such rule set: " swap append throw ;
+ "No such rule set: " prepend throw ;
: get-rule-set ( name -- rule-sets rules )
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
From d0b348591a41e023fdc5576e52cb269d4f53e373 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 19:15:43 -0500
Subject: [PATCH 112/197] path+, prepend
---
core/bootstrap/stage2.factor | 2 +-
core/classes/union/union.factor | 2 +-
core/combinators/combinators.factor | 2 +-
core/command-line/command-line.factor | 4 ++--
core/compiler/tests/intrinsics.factor | 2 +-
core/generic/math/math.factor | 2 +-
core/generic/standard/standard.factor | 4 ++--
core/io/files/files-docs.factor | 4 ++--
core/io/files/files.factor | 17 ++++++++++-------
core/optimizer/specializers/specializers.factor | 2 +-
core/sequences/sequences.factor | 2 ++
core/syntax/syntax.factor | 5 +++++
core/vocabs/loader/loader-tests.factor | 2 +-
core/vocabs/loader/loader.factor | 10 +++++-----
14 files changed, 35 insertions(+), 25 deletions(-)
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 63b5726ad7..2aeb3099ac 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -25,7 +25,7 @@ SYMBOL: bootstrap-time
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff
- [ "bootstrap." swap append require ] each ;
+ [ "bootstrap." prepend require ] each ;
: compile-remaining ( -- )
"Compiling remaining words..." print flush
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index dcc05e8160..c1c82d158b 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -13,7 +13,7 @@ PREDICATE: class union-class
drop [ drop f ]
] [
unclip first "predicate" word-prop swap
- [ >r "predicate" word-prop [ dup ] swap append r> ]
+ [ >r "predicate" word-prop [ dup ] prepend r> ]
assoc-map alist>quot
] if ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index ffd1576e6e..53d18b53ca 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -80,7 +80,7 @@ M: hashtable hashcode*
: hash-case-quot ( default assoc -- quot )
hash-case-table hash-dispatch-quot
- [ dup hashcode >fixnum ] swap append ;
+ [ dup hashcode >fixnum ] prepend ;
: contiguous-range? ( keys -- from to ? )
dup [ fixnum? ] all? [
diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor
index ed4fb9f606..72c1e063e0 100644
--- a/core/command-line/command-line.factor
+++ b/core/command-line/command-line.factor
@@ -7,12 +7,12 @@ splitting io.files ;
: run-bootstrap-init ( -- )
"user-init" get [
- home ".factor-boot-rc" path+ ?run-file
+ home ".factor-boot-rc" append-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
- home ".factor-rc" path+ ?run-file
+ home ".factor-rc" append-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index dd9a453cfc..b854b4ef0d 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -385,7 +385,7 @@ cell 8 = [
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def word-def [ { fixnum } declare ] swap append ;
+: xword-def word-def [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 9fd5481a39..b01fb87f72 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -53,7 +53,7 @@ TUPLE: no-math-method left right generic ;
2dup and [
2dup math-upgrade >r
math-class-max over order min-class applicable-method
- r> swap append
+ r> prepend
] [
2drop object-method
] if ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index c634e02e75..35161319ef 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -161,7 +161,7 @@ C: <hook-combination> hook-combination
0 (dispatch#) [
swap slip
hook-combination-var [ get ] curry
- swap append
+ prepend
] with-variable ; inline
M: hook-combination make-default-method
@@ -170,7 +170,7 @@ M: hook-combination make-default-method
M: hook-combination perform-combination
[
standard-methods
- [ [ drop ] swap append ] assoc-map
+ [ [ drop ] prepend ] assoc-map
single-combination
] with-hook ;
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index df9c78fe47..1ee9d19e4a 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection parent-directory }
{ $subsection file-name }
{ $subsection last-path-separator }
-{ $subsection path+ }
+{ $subsection append-path }
"Pathnames relative to Factor's install directory:"
{ $subsection resource-path }
{ $subsection ?resource-path }
@@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified )
{ stat exists? directory? } related-words
-HELP: path+
+HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index a6320a7507..0d00197415 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- )
: left-trim-separators ( str -- newstr )
[ path-separator? ] left-trim ;
-: path+ ( str1 str2 -- str )
+: append-path ( str1 str2 -- str )
>r right-trim-separators "/" r>
left-trim-separators 3append ;
+: prepend-path ( str1 str2 -- str )
+ swap append-path ; inline
+
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ;
@@ -119,7 +122,7 @@ HOOK: make-directory io-backend ( path -- )
: fixup-directory ( path seq -- newseq )
[
dup string?
- [ tuck path+ directory? 2array ] [ nip ] if
+ [ tuck append-path directory? 2array ] [ nip ] if
] with map
[ first special-directory? not ] subset ;
@@ -127,7 +130,7 @@ HOOK: make-directory io-backend ( path -- )
normalize-directory dup (directory) fixup-directory ;
: directory* ( path -- seq )
- dup directory [ first2 >r path+ r> 2array ] with map ;
+ dup directory [ first2 >r append-path r> 2array ] with map ;
! Touching files
HOOK: touch-file io-backend ( path -- )
@@ -146,7 +149,7 @@ HOOK: delete-directory io-backend ( path -- )
: delete-tree ( path -- )
dup directory? (delete-tree) ;
-: to-directory over file-name path+ ;
+: to-directory over file-name append-path ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
@@ -179,7 +182,7 @@ DEFER: copy-tree-into
: copy-tree ( from to -- )
over directory? [
>r dup directory swap r> [
- >r swap first path+ r> copy-tree-into
+ >r swap first append-path r> copy-tree-into
] 2curry each
] [
copy-file
@@ -194,7 +197,7 @@ DEFER: copy-tree-into
! Special paths
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
- swap path+ ;
+ prepend-path ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
@@ -236,7 +239,7 @@ M: pathname <=> [ pathname-string ] compare ;
[ dup make-directory ]
when ;
-: temp-file ( name -- path ) temp-directory swap path+ ;
+: temp-file ( name -- path ) temp-directory prepend-path ;
! Home directory
: home ( -- dir )
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 5153d84c7f..560a174289 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -35,7 +35,7 @@ IN: optimizer.specializers
swap "method-class" word-prop add* ;
: specialize-method ( quot method -- quot' )
- method-declaration [ declare ] curry swap append ;
+ method-declaration [ declare ] curry prepend ;
: specialize-quot ( quot specializer -- quot' )
dup { number } = [
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 9fc5264440..3c69bfa41c 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -299,6 +299,8 @@ M: immutable-sequence clone-like like ;
: append ( seq1 seq2 -- newseq ) over (append) ;
+: prepend ( seq1 seq2 -- newseq ) swap append ; inline
+
: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
: change-nth ( i seq quot -- )
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index d9870b08da..8cc9211599 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -163,6 +163,11 @@ IN: bootstrap.syntax
[ construct-boa ] curry define-inline
] define-syntax
+ "ERROR:" [
+ CREATE-CLASS dup ";" parse-tokens define-tuple-class
+ dup [ construct-boa throw ] curry define
+ ] define-syntax
+
"FORGET:" [
scan-word
dup parsing? [ V{ } clone swap execute first ] when
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 0519096128..85399ca9e7 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -136,7 +136,7 @@ IN: vocabs.loader.tests
[
{ "2" "a" "b" "d" "e" "f" }
[
- "vocabs.loader.test." swap append forget-vocab
+ "vocabs.loader.test." prepend forget-vocab
] each
] with-compilation-unit ;
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 9833b2834f..103b5290a4 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -25,7 +25,7 @@ V{
: vocab-dir? ( root name -- ? )
over [
- ".factor" vocab-dir+ path+ resource-exists?
+ ".factor" vocab-dir+ append-path resource-exists?
] [
2drop f
] if ;
@@ -39,14 +39,14 @@ H{ } clone root-cache set-global
vocab-roots get swap [ vocab-dir? ] curry find nip
] cache ;
-: vocab-path+ ( vocab path -- newpath )
- swap find-vocab-root dup [ swap path+ ] [ 2drop f ] if ;
+: vocab-append-path ( vocab path -- newpath )
+ swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
: vocab-source-path ( vocab -- path/f )
- dup ".factor" vocab-dir+ vocab-path+ ;
+ dup ".factor" vocab-dir+ vocab-append-path ;
: vocab-docs-path ( vocab -- path/f )
- dup "-docs.factor" vocab-dir+ vocab-path+ ;
+ dup "-docs.factor" vocab-dir+ vocab-append-path ;
SYMBOL: load-help?
From f5e678c3801cd33f0348ac67b631784c6cb6e250 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 19:37:04 -0500
Subject: [PATCH 113/197] work on gmt-offset on windows
---
extra/calendar/windows/windows.factor | 14 ++++++++++----
1 file changed, 10 insertions(+), 4 deletions(-)
diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor
index 9e34fdac00..acbae2fcd3 100755
--- a/extra/calendar/windows/windows.factor
+++ b/extra/calendar/windows/windows.factor
@@ -8,8 +8,14 @@ T{ windows-calendar } calendar-backend set-global
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
-M: windows-calendar gmt-offset ( -- float )
+M: windows-calendar gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
- dup GetTimeZoneInformation
- TIME_ZONE_ID_INVALID = [ win32-error ] when
- TIME_ZONE_INFORMATION-Bias 60 / neg ;
+ dup GetTimeZoneInformation {
+ { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
+ { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
+ [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
+ { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
+ [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
+ [ TIME_ZONE_INFORMATION-DaylightBias ] bi
+ ] }
+ } cond ;
From 264284d0c4dac5d6b70232fc1ff35b1bba0573c8 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 13:40:22 +1300
Subject: [PATCH 114/197] Add range-pattern parser
---
extra/peg/parsers/parsers-docs.factor | 18 ++++++++++++++++
extra/peg/parsers/parsers.factor | 30 ++++++++++++++++++++++++++-
2 files changed, 47 insertions(+), 1 deletion(-)
diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor
index 1991cba0eb..d49f1158dd 100755
--- a/extra/peg/parsers/parsers-docs.factor
+++ b/extra/peg/parsers/parsers-docs.factor
@@ -159,3 +159,21 @@ HELP: 'string'
} { $description
"Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
} { $see-also 'integer' } ;
+
+HELP: range-pattern
+{ $values
+ { "pattern" "a string" }
+ { "parser" "a parser" }
+} { $description
+"Returns a parser that matches a single character based on the set "
+"of characters in the pattern string."
+"Any single character in the pattern matches that character. "
+"If the pattern begins with a ^ then the set is negated "
+"(the element matches any character not in the set). Any pair "
+"of characters separated with a dash (-) represents the "
+"range of characters from the first to the second, inclusive."
+{ $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" }
+}
+} ;
diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor
index 87306e1469..63e9e9a336 100755
--- a/extra/peg/parsers/parsers.factor
+++ b/extra/peg/parsers/parsers.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser match
- unicode.categories sequences.deep peg peg.private ;
+ unicode.categories sequences.deep peg peg.private
+ peg.search math.ranges ;
IN: peg.parsers
TUPLE: just-parser p1 ;
@@ -83,3 +84,30 @@ MEMO: 'string' ( -- parser )
[ CHAR: " = not ] satisfy repeat0 ,
[ CHAR: " = ] satisfy hide ,
] { } make seq [ first >string ] action ;
+
+: (range-pattern) ( pattern -- string )
+ #! Given a range pattern, produce a string containing
+ #! all characters within that range.
+ [
+ any-char ,
+ [ CHAR: - = ] satisfy hide ,
+ any-char ,
+ ] seq* [
+ first2 [a,b] >string
+ ] action
+ replace ;
+
+MEMO: range-pattern ( pattern -- parser )
+ #! 'pattern' is a set of characters describing the
+ #! parser to be produced. Any single character in
+ #! the pattern matches that character. If the pattern
+ #! begins with a ^ then the set is negated (the element
+ #! matches any character not in the set). Any pair of
+ #! characters separated with a dash (-) represents the
+ #! range of characters from the first to the second,
+ #! inclusive.
+ dup first CHAR: ^ = [
+ 1 tail (range-pattern) [ member? not ] curry satisfy
+ ] [
+ (range-pattern) [ member? ] curry satisfy
+ ] if ;
From 795ef0ae3b0a5031b329c84d555a1c64bfeae758 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 13:55:19 +1300
Subject: [PATCH 115/197] Add ranges to EBNF syntax This works: <EBNF letter
= [a-zA-Z] EBNF> and <EBNF not-digit = [^0-9] EBNF>
---
extra/peg/ebnf/ebnf-tests.factor | 24 ++++++++++++++++++++++++
extra/peg/ebnf/ebnf.factor | 14 ++++++++++++++
2 files changed, 38 insertions(+)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 8846a9c94c..458c68e0d4 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -118,4 +118,28 @@ IN: peg.ebnf.tests
{ V{ 1 2 } } [
"foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+] unit-test
+
+{ CHAR: A } [
+ "foo=[A-Z]" ebnf>quot with-compilation-unit "A" foo parse parse-result-ast
+] unit-test
+
+{ CHAR: Z } [
+ "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" foo parse parse-result-ast
+] unit-test
+
+{ f } [
+ "foo=[A-Z]" ebnf>quot with-compilation-unit "0" foo parse
+] unit-test
+
+{ CHAR: 0 } [
+ "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" foo parse parse-result-ast
+] unit-test
+
+{ f } [
+ "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" foo parse
+] unit-test
+
+{ f } [
+ "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" foo parse
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e2c2dd5006..03f36c5f28 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -9,6 +9,7 @@ IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-any-character ;
+TUPLE: ebnf-range pattern ;
TUPLE: ebnf-ensure-not group ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
@@ -22,6 +23,7 @@ TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-any-character> ebnf-any-character
+C: <ebnf-range> ebnf-range
C: <ebnf-ensure-not> ebnf-ensure-not
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
@@ -69,6 +71,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id )
M: ebnf-any-character (generate-parser) ( ast -- id )
drop [ drop t ] satisfy store-parser ;
+M: ebnf-range (generate-parser) ( ast -- id )
+ ebnf-range-pattern range-pattern store-parser ;
+
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
@@ -163,6 +168,14 @@ DEFER: 'rhs'
: 'any-character' ( -- parser )
#! A parser to match the symbol for any character match.
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
+
+: 'range-parser' ( -- parser )
+ #! Match the syntax for declaring character ranges
+ [
+ "[" syntax ,
+ [ CHAR: ] = not ] satisfy repeat1 ,
+ "]" syntax ,
+ ] seq* [ first >string <ebnf-range> ] action ;
: 'element' ( -- parser )
#! An element of a rule. It can be a terminal or a
@@ -173,6 +186,7 @@ DEFER: 'rhs'
[
'non-terminal' ,
'terminal' ,
+ 'range-parser' ,
'any-character' ,
] choice* ,
"=" syntax ensure-not ,
From ec4f964e4f770f912cc9e1674bd790abcebc7f53 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 14:06:21 +1300
Subject: [PATCH 116/197] Fix pl0 for EBNF syntax changes
---
extra/peg/pl0/pl0.factor | 16 ++++++++--------
1 file changed, 8 insertions(+), 8 deletions(-)
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index 1ef7a23b41..b30f6bfe70 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -16,16 +16,16 @@ MEMO: number ( -- parser )
<EBNF
program = block "."
-block = [ "CONST" ident "=" number { "," ident "=" number } ";" ]
- [ "VAR" ident { "," ident } ";" ]
- { "PROCEDURE" ident ";" [ block ";" ] } statement
-statement = [ ident ":=" expression | "CALL" ident |
- "BEGIN" statement {";" statement } "END" |
+block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )?
+ ( "VAR" ident ( "," ident )* ";" )?
+ ( "PROCEDURE" ident ";" ( block ";" )? )* statement
+statement = ( ident ":=" expression | "CALL" ident |
+ "BEGIN" statement (";" statement )* "END" |
"IF" condition "THEN" statement |
- "WHILE" condition "DO" statement ]
+ "WHILE" condition "DO" statement )?
condition = "ODD" expression |
expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression
-expression = ["+" | "-"] term {("+" | "-") term }
-term = factor {("*" | "/") factor }
+expression = ("+" | "-")? term (("+" | "-") term )*
+term = factor (("*" | "/") factor )*
factor = ident | number | "(" expression ")"
EBNF>
From 68388fbed90e0765925491d2ccc6ff3354bf7c0b Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 14:15:06 +1300
Subject: [PATCH 117/197] Updated peg.expr to use range-pattern for digits
---
extra/peg/expr/expr-tests.factor | 25 +++++++++++++++++++++++++
extra/peg/expr/expr.factor | 5 ++---
2 files changed, 27 insertions(+), 3 deletions(-)
create mode 100644 extra/peg/expr/expr-tests.factor
diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor
new file mode 100644
index 0000000000..0ed05765cd
--- /dev/null
+++ b/extra/peg/expr/expr-tests.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg.expr multiline sequences ;
+IN: temporary
+
+{ 5 } [
+ "2+3" eval-expr
+] unit-test
+
+{ 6 } [
+ "2*3" eval-expr
+] unit-test
+
+{ 14 } [
+ "2+3*4" eval-expr
+] unit-test
+
+{ 17 } [
+ "2+3*4+3" eval-expr
+] unit-test
+
+{ 23 } [
+ "2+3*(4+3)" eval-expr
+] unit-test
diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor
index ed13ac0e50..26ae76c0b0 100644
--- a/extra/peg/expr/expr.factor
+++ b/extra/peg/expr/expr.factor
@@ -16,9 +16,8 @@ divide = ("/") [[ drop [ / ] ]]
add = ("+") [[ drop [ + ] ]]
subtract = ("-") [[ drop [ - ] ]]
-digit = "0" | "1" | "2" | "3" | "4" |
- "5" | "6" | "7" | "8" | "9"
-number = ((digit)+) [[ concat string>number ]]
+digit = ([0-9]) [[ digit> ]]
+number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
value = number | ("(" expr ")") [[ second ]]
product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
From 39c228db6d14ae9229d712abb716489248c3dca8 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 14:22:14 +1300
Subject: [PATCH 118/197] Update peg.pl0 to use range pattern syntax This
allows removing the words for ident and number, replacing them with EBNF
expressions.
---
extra/peg/pl0/pl0.factor | 13 ++++---------
1 file changed, 4 insertions(+), 9 deletions(-)
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index b30f6bfe70..34973e6a52 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -1,18 +1,10 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences
-peg peg.ebnf peg.parsers memoize namespaces ;
+peg peg.ebnf peg.parsers memoize namespaces math ;
IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
-MEMO: ident ( -- parser )
- [
- CHAR: a CHAR: z range ,
- CHAR: A CHAR: Z range ,
- ] choice* repeat1 [ >string ] action ;
-
-MEMO: number ( -- parser )
- CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
<EBNF
program = block "."
@@ -28,4 +20,7 @@ condition = "ODD" expression |
expression = ("+" | "-")? term (("+" | "-") term )*
term = factor (("*" | "/") factor )*
factor = ident | number | "(" expression ")"
+ident = (([a-zA-Z])+) [[ >string ]]
+digit = ([0-9]) [[ digit> ]]
+number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
EBNF>
From c1f69f01beb2c6a183e42bd13b81a40374039baf Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 14:57:12 +1300
Subject: [PATCH 119/197] Change ordering of [[ ... ]]
---
extra/peg/ebnf/ebnf-tests.factor | 20 ++++++++++----------
extra/peg/ebnf/ebnf.factor | 28 +++++++++++++++-------------
extra/peg/expr/expr-tests.factor | 2 +-
extra/peg/expr/expr.factor | 3 ++-
4 files changed, 28 insertions(+), 25 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 458c68e0d4..0989e4beb5 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf compiler.units ;
+USING: kernel parser words tools.test peg peg.ebnf compiler.units ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -109,37 +109,37 @@ IN: peg.ebnf.tests
] unit-test
{ V{ "a" "b" } } [
- "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+ "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast
] unit-test
{ V{ 1 "b" } } [
- "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+ "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast
] unit-test
{ V{ 1 2 } } [
- "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
+ "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast
] unit-test
{ CHAR: A } [
- "foo=[A-Z]" ebnf>quot with-compilation-unit "A" foo parse parse-result-ast
+ "foo=[A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse parse-result-ast
] unit-test
{ CHAR: Z } [
- "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" foo parse parse-result-ast
+ "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse parse-result-ast
] unit-test
{ f } [
- "foo=[A-Z]" ebnf>quot with-compilation-unit "0" foo parse
+ "foo=[A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse
] unit-test
{ CHAR: 0 } [
- "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" foo parse parse-result-ast
+ "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse parse-result-ast
] unit-test
{ f } [
- "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" foo parse
+ "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse
] unit-test
{ f } [
- "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" foo parse
+ "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 03f36c5f28..7d298a709d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -172,7 +172,7 @@ DEFER: 'rhs'
: 'range-parser' ( -- parser )
#! Match the syntax for declaring character ranges
[
- "[" syntax ,
+ [ "[" syntax , "[" token ensure-not , ] seq* hide ,
[ CHAR: ] = not ] satisfy repeat1 ,
"]" syntax ,
] seq* [ first >string <ebnf-range> ] action ;
@@ -208,7 +208,6 @@ DEFER: 'choice'
"*" token sp ensure-not ,
"+" token sp ensure-not ,
"?" token sp ensure-not ,
- "[[" token sp ensure-not ,
] seq* hide grouped ;
: 'repeat0' ( -- parser )
@@ -226,13 +225,6 @@ DEFER: 'choice'
[ drop t ] satisfy ,
] seq* [ first ] action repeat0 [ >string ] action ;
-: 'action' ( -- parser )
- [
- "(" [ 'choice' sp ] delay ")" syntax-pack ,
- "[[" 'factor-code' "]]" syntax-pack ,
- ] seq* [ first2 <ebnf-action> ] action ;
-
-
: 'ensure-not' ( -- parser )
#! Parses the '!' syntax to ensure that
#! something that matches the following elements do
@@ -242,7 +234,7 @@ DEFER: 'choice'
'group' sp ,
] seq* [ first <ebnf-ensure-not> ] action ;
-: 'sequence' ( -- parser )
+: ('sequence') ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
@@ -252,11 +244,21 @@ DEFER: 'choice'
'repeat0' sp ,
'repeat1' sp ,
'optional' sp ,
- 'action' sp ,
+ ] choice* ;
+
+: 'sequence' ( -- parser )
+ #! A sequence of terminals and non-terminals, including
+ #! groupings of those.
+ [
+ [
+ ('sequence') ,
+ "[[" 'factor-code' "]]" syntax-pack ,
+ ] seq* [ first2 <ebnf-action> ] action ,
+ ('sequence') ,
] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
- ] action ;
-
+ ] action ;
+
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor
index 0ed05765cd..20da5cd16a 100644
--- a/extra/peg/expr/expr-tests.factor
+++ b/extra/peg/expr/expr-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg.expr multiline sequences ;
+USING: kernel tools.test peg peg.expr multiline sequences ;
IN: temporary
{ 5 } [
diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor
index 26ae76c0b0..62ef4ea88f 100644
--- a/extra/peg/expr/expr.factor
+++ b/extra/peg/expr/expr.factor
@@ -26,4 +26,5 @@ expr = sum
EBNF>
: eval-expr ( string -- number )
- expr parse parse-result-ast ;
\ No newline at end of file
+ expr parse parse-result-ast ;
+
From 6f2369b16ecf85a79eb0d4366e585222f451071d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Mar 2008 21:15:38 -0500
Subject: [PATCH 120/197] add code to bootstrap.syntax
---
core/bootstrap/syntax.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index a4e87f28d8..e7e90d8dd0 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -21,6 +21,7 @@ IN: bootstrap.syntax
"C:"
"CHAR:"
"DEFER:"
+ "ERROR:"
"F{"
"FV{"
"FORGET:"
From 27e87292f04823d9b469634f83e9e07908041252 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Wed, 19 Mar 2008 21:16:09 -0500
Subject: [PATCH 121/197] Add [let* syntax
---
extra/locals/locals-docs.factor | 21 +++-
extra/locals/locals-tests.factor | 33 +++++++
extra/locals/locals.factor | 164 +++++++++++++++++++------------
3 files changed, 152 insertions(+), 66 deletions(-)
diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor
index 62f2eac513..372a567550 100644
--- a/extra/locals/locals-docs.factor
+++ b/extra/locals/locals-docs.factor
@@ -25,7 +25,7 @@ $with-locals-note ;
HELP: [let
{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
+{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
{ $examples
{ $example
"USING: kernel locals math math.functions prettyprint sequences ;"
@@ -38,6 +38,24 @@ HELP: [let
}
$with-locals-note ;
+HELP: [let*
+{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
+{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
+{ $examples
+ { $example
+ "USING: kernel locals math math.functions prettyprint sequences ;"
+ ":: frobnicate ( n seq -- newseq )"
+ " [let* | a [ n 3 + ]"
+ " b [ a 4 * ] |"
+ " seq [ b / ] map ] ;"
+ "1 { 32 48 } frobnicate ."
+ "{ 2 3 }"
+ }
+}
+$with-locals-note ;
+
+{ POSTPONE: [let POSTPONE: [let* } related-words
+
HELP: [wlet
{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" }
{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." }
@@ -106,6 +124,7 @@ $nl
{ $subsection with-locals }
"Lexical binding forms:"
{ $subsection POSTPONE: [let }
+{ $subsection POSTPONE: [let* }
{ $subsection POSTPONE: [wlet }
"Lambda abstractions:"
{ $subsection POSTPONE: [| }
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index bd1e62f22a..4ee9b48bb7 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -195,3 +195,36 @@ DEFER: xyzzy
] unit-test
[ 5 ] [ 10 xyzzy ] unit-test
+
+:: let*-test-1 ( a -- b )
+ [let* | b [ a 1+ ]
+ c [ b 1+ ] |
+ a b c 3array ] ;
+
+[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
+
+:: let*-test-2 ( a -- b )
+ [let* | b [ a 1+ ]
+ c! [ b 1+ ] |
+ a b c 3array ] ;
+
+[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
+
+:: let*-test-3 ( a -- b )
+ [let* | b [ a 1+ ]
+ c! [ b 1+ ] |
+ c 1+ c! a b c 3array ] ;
+
+[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
+
+:: let*-test-4 ( a b -- c d )
+ [let | a [ b ]
+ b [ a ] |
+ [let* | a' [ a ]
+ a'' [ a' ]
+ b' [ b ]
+ b'' [ b' ] |
+ a'' b'' ] ] ;
+
+[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
+
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index a8f5e139e7..d7788c80bc 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private effects generic
-compiler.units combinators.cleave ;
+compiler.units combinators.cleave new-slots accessors ;
IN: locals
! Inspired by
@@ -17,11 +17,15 @@ TUPLE: lambda vars body ;
C: <lambda> lambda
-TUPLE: let bindings vars body ;
+TUPLE: let bindings body ;
C: <let> let
-TUPLE: wlet bindings vars body ;
+TUPLE: let* bindings body ;
+
+C: <let*> let*
+
+TUPLE: wlet bindings body ;
C: <wlet> wlet
@@ -137,7 +141,7 @@ M: object free-vars drop { } ;
M: quotation free-vars { } [ add-if-free ] reduce ;
M: lambda free-vars
- dup lambda-vars swap lambda-body free-vars seq-diff ;
+ dup vars>> swap body>> free-vars seq-diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
@@ -164,12 +168,12 @@ M: callable block-body ;
M: callable local-rewrite*
[ [ local-rewrite* ] each ] [ ] make , ;
-M: lambda block-vars lambda-vars ;
+M: lambda block-vars vars>> ;
-M: lambda block-body lambda-body ;
+M: lambda block-body body>> ;
M: lambda local-rewrite*
- dup lambda-vars swap lambda-body
+ dup vars>> swap body>>
[ local-rewrite* \ call , ] [ ] make <lambda> , ;
M: block lambda-rewrite*
@@ -187,24 +191,18 @@ M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: make-locals ( seq -- words assoc )
- [
- "!" ?tail [ <local-reader> ] [ <local> ] if
- ] map dup [
- dup
- [ dup word-name set ] each
- [
- dup local-reader? [
- <local-writer> dup word-name set
- ] [
- drop
- ] if
- ] each
- ] H{ } make-assoc ;
+: make-local ( name -- word )
+ "!" ?tail [
+ <local-reader>
+ dup <local-writer> dup word-name set
+ ] [ <local> ] if
+ dup dup word-name set ;
-: make-local-words ( seq -- words assoc )
- [ dup <local-word> ] { } map>assoc
- dup values swap ;
+: make-locals ( seq -- words assoc )
+ [ [ make-local ] map ] H{ } make-assoc ;
+
+: make-local-word ( name -- word )
+ <local-word> dup dup word-name set ;
: push-locals ( assoc -- )
use get push ;
@@ -213,41 +211,75 @@ M: object local-rewrite* , ;
use get delete ;
: (parse-lambda) ( assoc end -- quot )
- over push-locals parse-until >quotation swap pop-locals ;
+ parse-until >quotation swap pop-locals ;
: parse-lambda ( -- lambda )
- "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
+ "|" parse-tokens make-locals dup push-locals
+ \ ] (parse-lambda) <lambda> ;
-: (parse-bindings) ( -- )
+: parse-binding ( -- pair/f )
scan dup "|" = [
- drop
+ drop f
] [
scan {
{ "[" [ \ ] parse-until >quotation ] }
{ "[|" [ parse-lambda ] }
- } case 2array ,
- (parse-bindings)
+ } case 2array
] if ;
-: parse-bindings ( -- alist )
- scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
+: (parse-bindings) ( -- )
+ parse-binding [
+ first2 >r make-local r> 2array ,
+ (parse-bindings)
+ ] when* ;
+
+: parse-bindings ( -- bindings vars )
+ [
+ [ (parse-bindings) ] H{ } make-assoc
+ dup push-locals
+ ] { } make swap ;
+
+: parse-bindings* ( -- words assoc )
+ [
+ [
+ namespace push-locals
+
+ (parse-bindings)
+ ] { } make-assoc
+ ] { } make swap ;
+
+: (parse-wbindings) ( -- )
+ parse-binding [
+ first2 >r make-local-word r> 2array ,
+ (parse-wbindings)
+ ] when* ;
+
+: parse-wbindings ( -- bindings vars )
+ [
+ [ (parse-wbindings) ] H{ } make-assoc
+ dup push-locals
+ ] { } make swap ;
+
+: let-rewrite ( body bindings -- )
+ <reversed> [
+ >r 1array r> spin <lambda> [ call ] curry compose
+ ] assoc-each local-rewrite* \ call , ;
M: let local-rewrite*
- { let-bindings let-vars let-body } get-slots -rot
- [ <reversed> ] 2apply
- [
- 1array -rot second -rot <lambda>
- [ call ] curry compose
- ] 2each local-rewrite* \ call , ;
+ { body>> bindings>> } get-slots let-rewrite ;
+
+M: let* local-rewrite*
+ { body>> bindings>> } get-slots let-rewrite ;
M: wlet local-rewrite*
- dup wlet-bindings values over wlet-vars rot wlet-body
- <lambda> [ call ] curry compose local-rewrite* \ call , ;
+ { body>> bindings>> } get-slots
+ [ [ ] curry ] assoc-map
+ let-rewrite ;
-: parse-locals
+: parse-locals ( -- vars assoc )
parse-effect
word [ over "declared-effect" set-word-prop ] when*
- effect-in make-locals ;
+ effect-in make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
@@ -263,14 +295,17 @@ PRIVATE>
: [| parse-lambda parsed ; parsing
: [let
- parse-bindings
- make-locals \ ] (parse-lambda)
- <let> parsed ; parsing
+ scan "|" assert= parse-bindings
+\ ] (parse-lambda) <let> parsed ; parsing
+
+: [let*
+ scan "|" assert= parse-bindings*
+ >r \ ] parse-until >quotation <let*> parsed r> pop-locals ;
+ parsing
: [wlet
- parse-bindings
- make-local-words \ ] (parse-lambda)
- <wlet> parsed ; parsing
+ scan "|" assert= parse-wbindings
+ \ ] (parse-lambda) <wlet> parsed ; parsing
MACRO: with-locals ( form -- quot ) lambda-rewrite ;
@@ -297,31 +332,30 @@ SYMBOL: |
M: lambda pprint*
<flow
\ [| pprint-word
- dup lambda-vars pprint-vars
+ dup vars>> pprint-vars
\ | pprint-word
- f <inset lambda-body pprint-elements block>
+ f <inset body>> pprint-elements block>
\ ] pprint-word
block> ;
-: pprint-let ( body vars bindings -- )
+: pprint-let ( let word -- )
+ pprint-word
+ { body>> bindings>> } get-slots
\ | pprint-word
t <inset
<block
- values [ <block >r pprint-var r> pprint* block> ] 2each
+ [ <block >r pprint-var r> pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
- block> ;
-
-M: let pprint*
- \ [let pprint-word
- { let-body let-vars let-bindings } get-slots pprint-let
+ block>
\ ] pprint-word ;
-M: wlet pprint*
- \ [wlet pprint-word
- { wlet-body wlet-vars wlet-bindings } get-slots pprint-let
- \ ] pprint-word ;
+M: let pprint* \ [let pprint-let ;
+
+M: wlet pprint* \ [wlet pprint-let ;
+
+M: let* pprint* \ [let* pprint-let ;
PREDICATE: word lambda-word
"lambda" word-prop >boolean ;
@@ -329,7 +363,7 @@ PREDICATE: word lambda-word
M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
- "lambda" word-prop lambda-body ;
+ "lambda" word-prop body>> ;
: lambda-word-synopsis ( word -- )
dup definer.
@@ -345,7 +379,7 @@ PREDICATE: macro lambda-macro
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
- "lambda" word-prop lambda-body ;
+ "lambda" word-prop body>> ;
M: lambda-macro synopsis* lambda-word-synopsis ;
@@ -355,10 +389,10 @@ PREDICATE: method-body lambda-method
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
- "lambda" word-prop lambda-body ;
+ "lambda" word-prop body>> ;
: method-stack-effect ( method -- effect )
- dup "lambda" word-prop lambda-vars
+ dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
dup [ effect-out ] when
<effect> ;
From 0d9947198ccc33ef92691f41ab111b7e446401b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 21:41:39 -0500
Subject: [PATCH 122/197] Bootstrap fixes
---
core/compiler/tests/intrinsics.factor | 6 +--
core/heaps/heaps-tests.factor | 2 +-
extra/bootstrap/random/random.factor | 6 ++-
extra/calendar/calendar.factor | 40 +++++++++----------
extra/calendar/windows/windows.factor | 21 +++++-----
extra/io/windows/nt/pipes/pipes.factor | 2 +-
.../mersenne-twister/mersenne-twister.factor | 2 -
extra/random/random.factor | 10 ++---
8 files changed, 45 insertions(+), 44 deletions(-)
mode change 100644 => 100755 extra/bootstrap/random/random.factor
mode change 100644 => 100755 extra/random/random.factor
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index b854b4ef0d..7a8fe5d735 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -261,7 +261,7 @@ cell 8 = [
: compiled-fixnum* fixnum* ;
: test-fixnum*
- (random) >fixnum (random) >fixnum
+ 32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if ;
@@ -271,7 +271,7 @@ cell 8 = [
: compiled-fixnum>bignum fixnum>bignum ;
: test-fixnum>bignum
- (random) >fixnum
+ 32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
@@ -280,7 +280,7 @@ cell 8 = [
: compiled-bignum>fixnum bignum>fixnum ;
: test-bignum>fixnum
- 5 random [ drop (random) ] map product >bignum
+ 5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor
index 61e09d894e..0b3123c87b 100755
--- a/core/heaps/heaps-tests.factor
+++ b/core/heaps/heaps-tests.factor
@@ -33,7 +33,7 @@ IN: heaps.tests
: random-alist ( n -- alist )
[
[
- (random) dup number>string swap set
+ 32 random-bits dup number>string swap set
] times
] H{ } make-assoc ;
diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor
old mode 100644
new mode 100755
index 7132860e1c..c4dc5dc660
--- a/extra/bootstrap/random/random.factor
+++ b/extra/bootstrap/random/random.factor
@@ -1,4 +1,5 @@
-USING: vocabs.loader sequences system ;
+USING: vocabs.loader sequences system
+random random.mersenne-twister ;
"random.mersenne-twister" require
@@ -6,3 +7,6 @@ USING: vocabs.loader sequences system ;
{ [ windows? ] [ "random.windows" require ] }
{ [ unix? ] [ "random.unix" require ] }
} cond
+
+[ millis <mersenne-twister> random-generator set-global ]
+"generator.random" add-init-hook
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 457b0bea11..7347363e5b 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -59,31 +59,29 @@ SYMBOL: m
PRIVATE>
-: julian-day-number ( year month day -- n )
+:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
- [
- 14 pick - 12 /i a set
- pick 4800 + a get - y set
- over 12 a get * + 3 - m set
- 2nip 153 m get * 2 + 5 /i + 365 y get * +
- y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
- ] with-scope ;
+ [let* | a [ 14 month - 12 /i ]
+ y [ year 4800 + a - ]
+ m [ month 12 a * + 3 - ] |
+ day 153 m * 2 + 5 /i + 365 y * +
+ y 4 /i + y 100 /i - y 400 /i + 32045 -
+ ] ;
-: julian-day-number>date ( n -- year month day )
+:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
- [
- 32044 + a set
- 4 a get * 3 + 146097 /i b set
- a get 146097 b get * 4 /i - c set
- 4 c get * 3 + 1461 /i d set
- c get 1461 d get * 4 /i - e set
- 5 e get * 2 + 153 /i m set
- 100 b get * d get + 4800 -
- m get 10 /i + m get 3 +
- 12 m get 10 /i * -
- e get 153 m get * 2 + 5 /i - 1+
- ] with-scope ;
+ [let* | a [ n 32044 + ]
+ b [ 4 a * 3 + 146097 /i ]
+ c [ a 146097 b * 4 /i - ]
+ d [ 4 c * 3 + 1461 /i ]
+ e [ c 1461 d * 4 /i - ]
+ m [ 5 e * 2 + 153 /i ] |
+ 100 b * d + 4800 -
+ m 10 /i + m 3 +
+ 12 m 10 /i * -
+ e 153 m * 2 + 5 /i - 1+
+ ] ;
: >date< ( timestamp -- year month day )
{ year>> month>> day>> } get-slots ;
diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor
index acbae2fcd3..1609b9f260 100755
--- a/extra/calendar/windows/windows.factor
+++ b/extra/calendar/windows/windows.factor
@@ -9,13 +9,14 @@ T{ windows-calendar } calendar-backend set-global
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
M: windows-calendar gmt-offset ( -- hours minutes seconds )
- "TIME_ZONE_INFORMATION" <c-object>
- dup GetTimeZoneInformation {
- { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
- { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
- [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
- { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
- [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
- [ TIME_ZONE_INFORMATION-DaylightBias ] bi
- ] }
- } cond ;
+ 0 0 0 ;
+ ! "TIME_ZONE_INFORMATION" <c-object>
+ ! dup GetTimeZoneInformation {
+ ! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
+ ! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
+ ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
+ ! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
+ ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
+ ! [ TIME_ZONE_INFORMATION-DaylightBias ] bi
+ ! ] }
+ ! } cond ;
diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor
index eb6dae2a0a..6fd38e74b2 100755
--- a/extra/io/windows/nt/pipes/pipes.factor
+++ b/extra/io/windows/nt/pipes/pipes.factor
@@ -56,7 +56,7 @@ TUPLE: pipe in out ;
"\\\\.\\pipe\\factor-" %
pipe counter #
"-" %
- (random) #
+ 32 random-bits #
"-" %
millis #
] "" make ;
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 79101c083e..c4e7cb2f7b 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -76,5 +76,3 @@ M: mersenne-twister random-32 ( mt -- r )
dup mt-n < [ drop 0 pick mt-generate ] unless
new-nth mt-temper
swap [ 1+ ] change-i drop ;
-
-[ millis <mersenne-twister> \ random set-global ] "random" add-init-hook
diff --git a/extra/random/random.factor b/extra/random/random.factor
old mode 100644
new mode 100755
index bbf54e21eb..0d8b137fc5
--- a/extra/random/random.factor
+++ b/extra/random/random.factor
@@ -15,16 +15,14 @@ GENERIC: random-32 ( tuple -- r )
: (random-bytes) ( tuple n -- byte-array )
[ drop random-32 ] with map >c-uint-array ;
-DEFER: random
+SYMBOL: random-generator
: random-bytes ( n -- r )
[
4 /mod zero? [ 1+ ] unless
- \ random get swap (random-bytes)
+ random-generator get swap (random-bytes)
] keep head ;
-: random-bits ( n -- r ) 2^ random ;
-
: random ( seq -- elt )
dup empty? [
drop f
@@ -35,5 +33,7 @@ DEFER: random
] keep nth
] if ;
+: random-bits ( n -- r ) 2^ random ;
+
: with-random ( tuple quot -- )
- \ random swap with-variable ; inline
+ random-generator swap with-variable ; inline
From e9d7e2523c35a64d2b172a20495118c4f40f8512 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 21:48:29 -0500
Subject: [PATCH 123/197] Clean up random and fix circular
---
core/bootstrap/stage2.factor | 2 +-
extra/bootstrap/random/random.factor | 3 ++-
extra/circular/circular-tests.factor | 6 ++++--
extra/circular/circular.factor | 4 ++--
extra/random/mersenne-twister/mersenne-twister-tests.factor | 5 ++---
extra/random/mersenne-twister/mersenne-twister.factor | 5 ++---
6 files changed, 13 insertions(+), 12 deletions(-)
mode change 100644 => 100755 extra/circular/circular-tests.factor
mode change 100644 => 100755 extra/circular/circular.factor
mode change 100644 => 100755 extra/random/mersenne-twister/mersenne-twister-tests.factor
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 2aeb3099ac..2523841aaf 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -57,7 +57,7 @@ millis >r
default-image-name "output-image" set-global
-"math help handbook compiler tools ui ui.tools io" "include" set-global
+"math help handbook compiler random tools ui ui.tools io" "include" set-global
"" "exclude" set-global
parse-command-line
diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor
index c4dc5dc660..b61e002526 100755
--- a/extra/bootstrap/random/random.factor
+++ b/extra/bootstrap/random/random.factor
@@ -1,5 +1,6 @@
USING: vocabs.loader sequences system
-random random.mersenne-twister ;
+random random.mersenne-twister combinators init
+namespaces ;
"random.mersenne-twister" require
diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor
old mode 100644
new mode 100755
index 8ca4574885..9023ab1dba
--- a/extra/circular/circular-tests.factor
+++ b/extra/circular/circular-tests.factor
@@ -9,7 +9,6 @@ circular strings ;
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
[ "test" ] [ "test" <circular> >string ] unit-test
-[ "test" <circular> 5 swap nth ] must-fail
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
@@ -18,10 +17,13 @@ circular strings ;
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
-[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
[ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
+
+! This no longer fails
+! [ "test" <circular> 5 swap nth ] must-fail
+! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
diff --git a/extra/circular/circular.factor b/extra/circular/circular.factor
old mode 100644
new mode 100755
index 8760e26586..08deb004e8
--- a/extra/circular/circular.factor
+++ b/extra/circular/circular.factor
@@ -18,9 +18,9 @@ M: circular length circular-seq length ;
M: circular virtual@ circular-wrap circular-seq ;
-M: circular nth bounds-check virtual@ nth ;
+M: circular nth virtual@ nth ;
-M: circular set-nth bounds-check virtual@ set-nth ;
+M: circular set-nth virtual@ set-nth ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor
old mode 100644
new mode 100755
index afd9d085b6..49bf4ad3f3
--- a/extra/random/mersenne-twister/mersenne-twister-tests.factor
+++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor
@@ -1,7 +1,6 @@
USING: kernel math random namespaces random.mersenne-twister
sequences tools.test ;
IN: random.mersenne-twister.tests
-USE: tools.walker
: check-random ( max -- ? )
dup >r random 0 r> between? ;
@@ -17,11 +16,11 @@ USE: tools.walker
[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
[ 1333075495 ] [
- 0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng
+ 0 [ 1000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng
] unit-test
[ 1575309035 ] [
- 0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng
+ 0 [ 10000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng
] unit-test
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index c4e7cb2f7b..73f241a370 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -3,9 +3,8 @@
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-USING: arrays kernel math namespaces sequences
-system init new-slots accessors
-math.ranges combinators.cleave circular random ;
+USING: arrays kernel math namespaces sequences system init
+new-slots accessors math.ranges combinators.cleave random ;
IN: random.mersenne-twister
<PRIVATE
From 7dc772db2647ebeb78c74dfa10d98b3963b5a94d Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 15:42:21 +1300
Subject: [PATCH 124/197] Refactor ebnf parser generation
---
extra/peg/ebnf/ebnf.factor | 52 ++++++++++++++++++++++++++++++++++++++
1 file changed, 52 insertions(+)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 7d298a709d..c7a007bfc8 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -34,6 +34,55 @@ C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
+GENERIC: (transform) ( ast -- parser )
+
+: transform ( ast -- object )
+ H{ } clone dup dup [ "parser" set swap (transform) "main" set ] bind ;
+
+M: ebnf (transform) ( ast -- parser )
+ ebnf-rules [ (transform) ] map peek ;
+
+M: ebnf-rule (transform) ( ast -- parser )
+ dup ebnf-rule-elements (transform) [
+ swap ebnf-rule-symbol set
+ ] keep ;
+
+M: ebnf-sequence (transform) ( ast -- parser )
+ ebnf-sequence-elements [ (transform) ] map seq ;
+
+M: ebnf-choice (transform) ( ast -- parser )
+ ebnf-choice-options [ (transform) ] map choice ;
+
+M: ebnf-any-character (transform) ( ast -- parser )
+ drop any-char ;
+
+M: ebnf-range (transform) ( ast -- parser )
+ ebnf-range-pattern range-pattern ;
+
+M: ebnf-ensure-not (transform) ( ast -- parser )
+ ebnf-ensure-not-group (transform) ensure-not ;
+
+M: ebnf-repeat0 (transform) ( ast -- parser )
+ ebnf-repeat0-group (transform) repeat0 ;
+
+M: ebnf-repeat1 (transform) ( ast -- parser )
+ ebnf-repeat1-group (transform) repeat1 ;
+
+M: ebnf-optional (transform) ( ast -- parser )
+ ebnf-optional-elements (transform) optional ;
+
+M: ebnf-action (transform) ( ast -- parser )
+ [ ebnf-action-parser (transform) ] keep
+ ebnf-action-code string-lines parse-lines action ;
+
+M: ebnf-terminal (transform) ( ast -- parser )
+ ebnf-terminal-symbol token sp ;
+
+M: ebnf-non-terminal (transform) ( ast -- parser )
+ ebnf-non-terminal-symbol [
+ , "parser" get , \ at ,
+ ] [ ] make delay ;
+
SYMBOL: parsers
SYMBOL: non-terminals
@@ -295,4 +344,7 @@ DEFER: 'choice'
f
] if* ;
+: transform-ebnf ( string -- object )
+ 'ebnf' parse parse-result-ast transform ;
+
: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing
From e7980ebc616579df199cef126e11f33d42a243ec Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 17:11:09 +1300
Subject: [PATCH 125/197] More refactoring of EBNF <EBNF .. EBNF> now produces
a quotation that when called does the parsing EBNF: foo ... ;EBNF creates a
'foo' word with stack effect (string -- result) when called it parses the
string and returns the result.
---
extra/peg/ebnf/ebnf-tests.factor | 20 +--
extra/peg/ebnf/ebnf.factor | 227 ++++++++++---------------------
extra/peg/expr/expr.factor | 7 +-
extra/peg/pl0/pl0-tests.factor | 12 +-
extra/peg/pl0/pl0.factor | 6 +-
5 files changed, 93 insertions(+), 179 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 0989e4beb5..6606fa9ffc 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel parser words tools.test peg peg.ebnf compiler.units ;
+USING: kernel tools.test peg peg.ebnf ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -109,37 +109,37 @@ IN: peg.ebnf.tests
] unit-test
{ V{ "a" "b" } } [
- "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast
+ "ab" <EBNF foo='a' 'b' EBNF> call parse-result-ast
] unit-test
{ V{ 1 "b" } } [
- "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast
+ "ab" <EBNF foo=('a')[[ drop 1 ]] 'b' EBNF> call parse-result-ast
] unit-test
{ V{ 1 2 } } [
- "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast
+ "ab" <EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF> call parse-result-ast
] unit-test
{ CHAR: A } [
- "foo=[A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse parse-result-ast
+ "A" <EBNF foo=[A-Z] EBNF> call parse-result-ast
] unit-test
{ CHAR: Z } [
- "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse parse-result-ast
+ "Z" <EBNF foo=[A-Z] EBNF> call parse-result-ast
] unit-test
{ f } [
- "foo=[A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse
+ "0" <EBNF foo=[A-Z] EBNF> call
] unit-test
{ CHAR: 0 } [
- "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse parse-result-ast
+ "0" <EBNF foo=[^A-Z] EBNF> call parse-result-ast
] unit-test
{ f } [
- "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse
+ "A" <EBNF foo=[^A-Z] EBNF> call
] unit-test
{ f } [
- "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse
+ "Z" <EBNF foo=[^A-Z] EBNF> call
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index c7a007bfc8..b9f88f5f24 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser words arrays strings math.parser sequences
+USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
splitting ;
@@ -34,136 +34,6 @@ C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
-GENERIC: (transform) ( ast -- parser )
-
-: transform ( ast -- object )
- H{ } clone dup dup [ "parser" set swap (transform) "main" set ] bind ;
-
-M: ebnf (transform) ( ast -- parser )
- ebnf-rules [ (transform) ] map peek ;
-
-M: ebnf-rule (transform) ( ast -- parser )
- dup ebnf-rule-elements (transform) [
- swap ebnf-rule-symbol set
- ] keep ;
-
-M: ebnf-sequence (transform) ( ast -- parser )
- ebnf-sequence-elements [ (transform) ] map seq ;
-
-M: ebnf-choice (transform) ( ast -- parser )
- ebnf-choice-options [ (transform) ] map choice ;
-
-M: ebnf-any-character (transform) ( ast -- parser )
- drop any-char ;
-
-M: ebnf-range (transform) ( ast -- parser )
- ebnf-range-pattern range-pattern ;
-
-M: ebnf-ensure-not (transform) ( ast -- parser )
- ebnf-ensure-not-group (transform) ensure-not ;
-
-M: ebnf-repeat0 (transform) ( ast -- parser )
- ebnf-repeat0-group (transform) repeat0 ;
-
-M: ebnf-repeat1 (transform) ( ast -- parser )
- ebnf-repeat1-group (transform) repeat1 ;
-
-M: ebnf-optional (transform) ( ast -- parser )
- ebnf-optional-elements (transform) optional ;
-
-M: ebnf-action (transform) ( ast -- parser )
- [ ebnf-action-parser (transform) ] keep
- ebnf-action-code string-lines parse-lines action ;
-
-M: ebnf-terminal (transform) ( ast -- parser )
- ebnf-terminal-symbol token sp ;
-
-M: ebnf-non-terminal (transform) ( ast -- parser )
- ebnf-non-terminal-symbol [
- , "parser" get , \ at ,
- ] [ ] make delay ;
-
-SYMBOL: parsers
-SYMBOL: non-terminals
-
-: reset-parser-generation ( -- )
- V{ } clone parsers set
- H{ } clone non-terminals set ;
-
-: store-parser ( parser -- number )
- parsers get [ push ] keep length 1- ;
-
-: get-parser ( index -- parser )
- parsers get nth ;
-
-: non-terminal-index ( name -- number )
- dup non-terminals get at [
- nip
- ] [
- f store-parser [ swap non-terminals get set-at ] keep
- ] if* ;
-
-GENERIC: (generate-parser) ( ast -- id )
-
-: generate-parser ( ast -- id )
- (generate-parser) ;
-
-M: ebnf-terminal (generate-parser) ( ast -- id )
- ebnf-terminal-symbol token sp store-parser ;
-
-M: ebnf-non-terminal (generate-parser) ( ast -- id )
- [
- ebnf-non-terminal-symbol dup non-terminal-index ,
- parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
- ] [ ] make delay sp store-parser ;
-
-M: ebnf-any-character (generate-parser) ( ast -- id )
- drop [ drop t ] satisfy store-parser ;
-
-M: ebnf-range (generate-parser) ( ast -- id )
- ebnf-range-pattern range-pattern store-parser ;
-
-M: ebnf-choice (generate-parser) ( ast -- id )
- ebnf-choice-options [
- generate-parser get-parser
- ] map choice store-parser ;
-
-M: ebnf-sequence (generate-parser) ( ast -- id )
- ebnf-sequence-elements [
- generate-parser get-parser
- ] map seq store-parser ;
-
-M: ebnf-ensure-not (generate-parser) ( ast -- id )
- ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ;
-
-M: ebnf-repeat0 (generate-parser) ( ast -- id )
- ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
-
-M: ebnf-repeat1 (generate-parser) ( ast -- id )
- ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ;
-
-M: ebnf-optional (generate-parser) ( ast -- id )
- ebnf-optional-elements generate-parser get-parser optional store-parser ;
-
-M: ebnf-rule (generate-parser) ( ast -- id )
- dup ebnf-rule-symbol non-terminal-index swap
- ebnf-rule-elements generate-parser get-parser ! nt-id body
- swap [ parsers get set-nth ] keep ;
-
-M: ebnf-action (generate-parser) ( ast -- id )
- [ ebnf-action-parser generate-parser get-parser ] keep
- ebnf-action-code string-lines parse-lines action store-parser ;
-
-M: vector (generate-parser) ( ast -- id )
- [ generate-parser ] map peek ;
-
-M: ebnf (generate-parser) ( ast -- id )
- ebnf-rules [
- generate-parser
- ] map peek ;
-
-DEFER: 'rhs'
-
: syntax ( string -- parser )
#! Parses the string, ignoring white space, and
#! does not put the result in the AST.
@@ -323,28 +193,81 @@ DEFER: 'choice'
: 'ebnf' ( -- parser )
'rule' sp repeat1 [ <ebnf> ] action ;
-: ebnf>quot ( string -- quot )
- 'ebnf' parse [
- parse-result-ast [
- reset-parser-generation
- generate-parser drop
- [
- non-terminals get
- [
- get-parser [
- swap , \ in , \ get , \ create ,
- 1quotation , \ define ,
- ] [
- drop
- ] if*
- ] assoc-each
- ] [ ] make
- ] with-scope
- ] [
- f
- ] if* ;
+GENERIC: (transform) ( ast -- parser )
+
+SYMBOL: parser
+SYMBOL: main
+
+: transform ( ast -- object )
+ H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
+
+M: ebnf (transform) ( ast -- parser )
+ ebnf-rules [ (transform) ] map peek ;
+
+M: ebnf-rule (transform) ( ast -- parser )
+ dup ebnf-rule-elements (transform) [
+ swap ebnf-rule-symbol set
+ ] keep ;
+
+M: ebnf-sequence (transform) ( ast -- parser )
+ ebnf-sequence-elements [ (transform) ] map seq ;
+
+M: ebnf-choice (transform) ( ast -- parser )
+ ebnf-choice-options [ (transform) ] map choice ;
+
+M: ebnf-any-character (transform) ( ast -- parser )
+ drop any-char ;
+
+M: ebnf-range (transform) ( ast -- parser )
+ ebnf-range-pattern range-pattern ;
+
+M: ebnf-ensure-not (transform) ( ast -- parser )
+ ebnf-ensure-not-group (transform) ensure-not ;
+
+M: ebnf-repeat0 (transform) ( ast -- parser )
+ ebnf-repeat0-group (transform) repeat0 ;
+
+M: ebnf-repeat1 (transform) ( ast -- parser )
+ ebnf-repeat1-group (transform) repeat1 ;
+
+M: ebnf-optional (transform) ( ast -- parser )
+ ebnf-optional-elements (transform) optional ;
+
+M: ebnf-action (transform) ( ast -- parser )
+ [ ebnf-action-parser (transform) ] keep
+ ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ;
+
+M: ebnf-terminal (transform) ( ast -- parser )
+ ebnf-terminal-symbol token sp ;
+
+M: ebnf-non-terminal (transform) ( ast -- parser )
+ ebnf-non-terminal-symbol [
+ , parser get , \ at ,
+ ] [ ] make delay sp ;
: transform-ebnf ( string -- object )
'ebnf' parse parse-result-ast transform ;
-: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing
+: check-parse-result ( result -- result )
+ dup [
+ dup parse-result-remaining empty? [
+ [
+ "Unable to fully parse EBNF. Left to parse was: " %
+ parse-result-remaining %
+ ] "" make throw
+ ] unless
+ ] [
+ "Could not parse EBNF" throw
+ ] if ;
+
+: ebnf>quot ( string -- hashtable quot )
+ 'ebnf' parse check-parse-result
+ parse-result-ast transform dup main swap at compile ;
+
+: <EBNF "EBNF>" parse-multiline-string ebnf>quot nip parsed ; parsing
+
+: EBNF:
+ CREATE-WORD dup
+ ";EBNF" parse-multiline-string
+ ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing
+
diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor
index 62ef4ea88f..14f0e7c14e 100644
--- a/extra/peg/expr/expr.factor
+++ b/extra/peg/expr/expr.factor
@@ -9,8 +9,7 @@ IN: peg.expr
#! { operator rhs } in to a tree structure of the correct precedence.
swap [ first2 swap call ] reduce ;
-<EBNF
-
+EBNF: expr
times = ("*") [[ drop [ * ] ]]
divide = ("/") [[ drop [ / ] ]]
add = ("+") [[ drop [ + ] ]]
@@ -23,8 +22,8 @@ value = number | ("(" expr ")") [[ second ]]
product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]]
expr = sum
-EBNF>
+;EBNF
: eval-expr ( string -- number )
- expr parse parse-result-ast ;
+ expr parse-result-ast ;
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index bf321d54e9..b3d2135da7 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -4,14 +4,6 @@
USING: kernel tools.test peg peg.pl0 multiline sequences ;
IN: peg.pl0.tests
-{ "abc" } [
- "abc" ident parse parse-result-ast
-] unit-test
-
-{ 55 } [
- "55abc" number parse parse-result-ast
-] unit-test
-
{ t } [
<"
VAR x, squ;
@@ -29,7 +21,7 @@ BEGIN
x := x + 1;
END
END.
-"> program parse parse-result-remaining empty?
+"> pl0 parse-result-remaining empty?
] unit-test
{ f } [
@@ -95,5 +87,5 @@ BEGIN
y := 36;
CALL gcd;
END.
- "> program parse parse-result-remaining empty?
+ "> pl0 parse-result-remaining empty?
] unit-test
\ No newline at end of file
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index 34973e6a52..f7eb3cad23 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -6,8 +6,7 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
-<EBNF
-program = block "."
+EBNF: pl0
block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )?
( "VAR" ident ( "," ident )* ";" )?
( "PROCEDURE" ident ";" ( block ";" )? )* statement
@@ -23,4 +22,5 @@ factor = ident | number | "(" expression ")"
ident = (([a-zA-Z])+) [[ >string ]]
digit = ([0-9]) [[ digit> ]]
number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
-EBNF>
+program = block "."
+;EBNF
From 44954753bdc0cdc593b6c8e8abd8efd8e4759ed0 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 17:13:27 +1300
Subject: [PATCH 126/197] Change <EBNF .. EBNF> to [EBNF .. EBNF]
---
extra/peg/ebnf/ebnf-tests.factor | 18 +++++++++---------
extra/peg/ebnf/ebnf.factor | 2 +-
2 files changed, 10 insertions(+), 10 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 6606fa9ffc..54639431a4 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -109,37 +109,37 @@ IN: peg.ebnf.tests
] unit-test
{ V{ "a" "b" } } [
- "ab" <EBNF foo='a' 'b' EBNF> call parse-result-ast
+ "ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast
] unit-test
{ V{ 1 "b" } } [
- "ab" <EBNF foo=('a')[[ drop 1 ]] 'b' EBNF> call parse-result-ast
+ "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast
] unit-test
{ V{ 1 2 } } [
- "ab" <EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF> call parse-result-ast
+ "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast
] unit-test
{ CHAR: A } [
- "A" <EBNF foo=[A-Z] EBNF> call parse-result-ast
+ "A" [EBNF foo=[A-Z] EBNF] call parse-result-ast
] unit-test
{ CHAR: Z } [
- "Z" <EBNF foo=[A-Z] EBNF> call parse-result-ast
+ "Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast
] unit-test
{ f } [
- "0" <EBNF foo=[A-Z] EBNF> call
+ "0" [EBNF foo=[A-Z] EBNF] call
] unit-test
{ CHAR: 0 } [
- "0" <EBNF foo=[^A-Z] EBNF> call parse-result-ast
+ "0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast
] unit-test
{ f } [
- "A" <EBNF foo=[^A-Z] EBNF> call
+ "A" [EBNF foo=[^A-Z] EBNF] call
] unit-test
{ f } [
- "Z" <EBNF foo=[^A-Z] EBNF> call
+ "Z" [EBNF foo=[^A-Z] EBNF] call
] unit-test
\ No newline at end of file
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index b9f88f5f24..caa1800297 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -264,7 +264,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
'ebnf' parse check-parse-result
parse-result-ast transform dup main swap at compile ;
-: <EBNF "EBNF>" parse-multiline-string ebnf>quot nip parsed ; parsing
+: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
: EBNF:
CREATE-WORD dup
From 8ade4f9b5b90b10fba1546bdb75d876356152129 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 17:16:50 +1300
Subject: [PATCH 127/197] Fix vocab name in expr tests
---
extra/peg/expr/expr-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor
index 20da5cd16a..b6f3163bf4 100644
--- a/extra/peg/expr/expr-tests.factor
+++ b/extra/peg/expr/expr-tests.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.expr multiline sequences ;
-IN: temporary
+IN: peg.expr.tests
{ 5 } [
"2+3" eval-expr
From dbd0583044940c4765caae207ef1e41f02e88994 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 17:19:41 +1300
Subject: [PATCH 128/197] Tidy up expr groups
---
extra/peg/expr/expr.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor
index 14f0e7c14e..6b690cb5ee 100644
--- a/extra/peg/expr/expr.factor
+++ b/extra/peg/expr/expr.factor
@@ -10,13 +10,13 @@ IN: peg.expr
swap [ first2 swap call ] reduce ;
EBNF: expr
-times = ("*") [[ drop [ * ] ]]
-divide = ("/") [[ drop [ / ] ]]
-add = ("+") [[ drop [ + ] ]]
-subtract = ("-") [[ drop [ - ] ]]
+times = "*" [[ drop [ * ] ]]
+divide = "/" [[ drop [ / ] ]]
+add = "+" [[ drop [ + ] ]]
+subtract = "-" [[ drop [ - ] ]]
-digit = ([0-9]) [[ digit> ]]
-number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
+digit = [0-9] [[ digit> ]]
+number = (digit)+ [[ unclip [ swap 10 * + ] reduce ]]
value = number | ("(" expr ")") [[ second ]]
product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
From d1e7ede35dc37c14bf3c28814fab0f0d47d18e7f Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 20 Mar 2008 17:25:27 +1300
Subject: [PATCH 129/197] Add support for & syntax in ebnf
---
extra/peg/ebnf/ebnf.factor | 16 ++++++++++++++++
1 file changed, 16 insertions(+)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index caa1800297..ab7baa547e 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -10,6 +10,7 @@ TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-any-character ;
TUPLE: ebnf-range pattern ;
+TUPLE: ebnf-ensure group ;
TUPLE: ebnf-ensure-not group ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
@@ -24,6 +25,7 @@ C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-any-character> ebnf-any-character
C: <ebnf-range> ebnf-range
+C: <ebnf-ensure> ebnf-ensure
C: <ebnf-ensure-not> ebnf-ensure-not
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
@@ -73,6 +75,7 @@ C: <ebnf> ebnf
[ dup CHAR: [ = ]
[ dup CHAR: . = ]
[ dup CHAR: ! = ]
+ [ dup CHAR: & = ]
[ dup CHAR: * = ]
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
@@ -153,11 +156,21 @@ DEFER: 'choice'
'group' sp ,
] seq* [ first <ebnf-ensure-not> ] action ;
+: 'ensure' ( -- parser )
+ #! Parses the '&' syntax to ensure that
+ #! something that matches the following elements does
+ #! exist in the parse stream.
+ [
+ "&" syntax ,
+ 'group' sp ,
+ ] seq* [ first <ebnf-ensure> ] action ;
+
: ('sequence') ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
'ensure-not' sp ,
+ 'ensure' sp ,
'element' sp ,
'group' sp ,
'repeat0' sp ,
@@ -221,6 +234,9 @@ M: ebnf-any-character (transform) ( ast -- parser )
M: ebnf-range (transform) ( ast -- parser )
ebnf-range-pattern range-pattern ;
+M: ebnf-ensure (transform) ( ast -- parser )
+ ebnf-ensure-group (transform) ensure ;
+
M: ebnf-ensure-not (transform) ( ast -- parser )
ebnf-ensure-not-group (transform) ensure-not ;
From aec6d6f5c88955d6e967c7a64d7a63fb0c413e2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 23:29:19 -0500
Subject: [PATCH 130/197] Replace (stat) with (exists?)
---
core/bootstrap/primitives.factor | 5 ++-
core/io/files/files-docs.factor | 14 +------
core/io/files/files.factor | 11 ++----
vm/io.h | 2 +-
vm/os-unix.c | 18 +--------
vm/os-windows.c | 65 +++++++++++---------------------
vm/primitives.c | 2 +-
7 files changed, 36 insertions(+), 81 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index e407bfd143..354ea672eb 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -91,8 +91,9 @@ call
} [ create-vocab drop ] each
H{ } clone source-files set
-H{ } clone class<map set
H{ } clone update-map set
+H{ } clone class<map set
+H{ } clone class-map set
! Builtin classes
: builtin-predicate-quot ( class -- quot )
@@ -547,7 +548,7 @@ builtins get num-tags get tail f union-class define-class
{ "eq?" "kernel" }
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
- { "(stat)" "io.files.private" }
+ { "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
{ "data-gc" "memory" }
{ "code-gc" "memory" }
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 1ee9d19e4a..1a3bde0e5c 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -54,9 +54,7 @@ ARTICLE: "fs-meta" "File meta-data"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
-{ $subsection directory? }
-! { $subsection file-modified }
-{ $subsection stat } ;
+{ $subsection directory? } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"Operations for deleting and copying files come in two forms:"
@@ -216,14 +214,6 @@ HELP: with-directory
{ $description "Changes the current working directory for the duration of a quotation's execution." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
-HELP: stat ( path -- directory? permissions length modified )
-{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
-{ $description
- "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
-} ;
-
-{ stat exists? directory? } related-words
-
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
@@ -273,7 +263,7 @@ HELP: normalize-directory
HELP: normalize-pathname
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
-{ $description "Called by the " { $link stat } " word, and possibly " { $link <file-reader> } " and " { $link <file-writer> } ", to prepare a pathname before passing it to underlying code." } ;
+{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
HELP: <pathname> ( str -- pathname )
{ $values { "str" "a pathname string" } { "pathname" pathname } }
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 0d00197415..3de7559303 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -86,14 +86,11 @@ SYMBOL: +socket+
SYMBOL: +unknown+
! File metadata
-: stat ( path -- directory? permissions length modified )
- normalize-pathname (stat) ;
+: exists? ( path -- ? )
+ normalize-pathname (exists?) ;
-: file-modified ( path -- n ) stat >r 3drop r> ;
-
-: exists? ( path -- ? ) file-modified >boolean ;
-
-: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
+: directory? ( path -- ? )
+ file-info file-info-type +directory+ = ;
! Current working directory
HOOK: cd io-backend ( path -- )
diff --git a/vm/io.h b/vm/io.h
index a19da3887c..6291db50ee 100755
--- a/vm/io.h
+++ b/vm/io.h
@@ -12,5 +12,5 @@ DECLARE_PRIMITIVE(fclose);
/* Platform specific primitives */
DECLARE_PRIMITIVE(open_file);
-DECLARE_PRIMITIVE(stat);
+DECLARE_PRIMITIVE(existsp);
DECLARE_PRIMITIVE(read_dir);
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 37dceb0d37..29d53487a3 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -41,24 +41,10 @@ void ffi_dlclose(F_DLL *dll)
dll->dll = NULL;
}
-DEFINE_PRIMITIVE(stat)
+DEFINE_PRIMITIVE(existsp)
{
struct stat sb;
-
- if(stat(unbox_char_string(),&sb) < 0)
- {
- dpush(F);
- dpush(F);
- dpush(F);
- dpush(F);
- }
- else
- {
- box_boolean(S_ISDIR(sb.st_mode));
- box_signed_4(sb.st_mode & ~S_IFMT);
- box_unsigned_8(sb.st_size);
- box_unsigned_8(sb.st_mtime);
- }
+ box_boolean(stat(unbox_char_string(),&sb) < 0);
}
/* Allocates memory */
diff --git a/vm/os-windows.c b/vm/os-windows.c
index f9b80ea32a..1be41f8b57 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -87,14 +87,6 @@ const F_CHAR *vm_executable_path(void)
return safe_strdup(full_path);
}
-void stat_not_found(void)
-{
- dpush(F);
- dpush(F);
- dpush(F);
- dpush(F);
-}
-
void find_file_stat(F_CHAR *path)
{
// FindFirstFile is the only call that can stat c:\pagefile.sys
@@ -102,56 +94,45 @@ void find_file_stat(F_CHAR *path)
HANDLE h;
if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
- stat_not_found();
+ dpush(F);
else
{
- box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
- dpush(tag_fixnum(0));
- box_unsigned_8(
- (u64)st.nFileSizeLow | (u64)st.nFileSizeHigh << 32);
-
- u64 lo = st.ftLastWriteTime.dwLowDateTime;
- u64 hi = st.ftLastWriteTime.dwHighDateTime;
- u64 modTime = (hi << 32) + lo;
-
- box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
FindClose(h);
+ dpush(T);
}
}
-DEFINE_PRIMITIVE(stat)
+DEFINE_PRIMITIVE(existsp)
{
- HANDLE h;
BY_HANDLE_FILE_INFORMATION bhfi;
F_CHAR *path = unbox_u16_string();
//wprintf(L"path = %s\n", path);
- h = CreateFileW(path,
- GENERIC_READ,
- FILE_SHARE_READ,
- NULL,
- OPEN_EXISTING,
- FILE_FLAG_BACKUP_SEMANTICS,
- NULL);
+ HANDLE h = CreateFileW(path,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
if(h == INVALID_HANDLE_VALUE)
{
- find_file_stat(path);
+ // FindFirstFile is the only call that can stat c:\pagefile.sys
+ WIN32_FIND_DATA st;
+ HANDLE h;
+
+ if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
+ dpush(F);
+ else
+ {
+ FindClose(h);
+ dpush(T);
+ }
return;
}
- if(!GetFileInformationByHandle(h, &bhfi))
- stat_not_found();
- else {
- box_boolean(bhfi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
- dpush(tag_fixnum(0));
- box_unsigned_8(
- (u64)bhfi.nFileSizeLow | (u64)bhfi.nFileSizeHigh << 32);
- u64 lo = bhfi.ftLastWriteTime.dwLowDateTime;
- u64 hi = bhfi.ftLastWriteTime.dwHighDateTime;
- u64 modTime = (hi << 32) + lo;
-
- box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
- }
+ box_boolean(GetFileInformationByHandle(h, &bhfi));
CloseHandle(h);
}
diff --git a/vm/primitives.c b/vm/primitives.c
index d1d956dca0..ce26c20f63 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -88,7 +88,7 @@ void *primitives[] = {
primitive_eq,
primitive_getenv,
primitive_setenv,
- primitive_stat,
+ primitive_existsp,
primitive_read_dir,
primitive_data_gc,
primitive_code_gc,
From 1ba4294bb230a71ee39b33e451398f76e667a309 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 23:29:35 -0500
Subject: [PATCH 131/197] Update smtp for random changes
---
extra/smtp/smtp.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index f7cdf9e64d..e15a90eda9 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -125,7 +125,7 @@ M: email clone
: message-id ( -- string )
[
"<" %
- 2 big-random #
+ 64 random-bits #
"-" %
millis #
"@" %
From 70641c9293b9ccbb40c1101f9642a264cbf5f504 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 23:29:59 -0500
Subject: [PATCH 132/197] Fix failing classes unit tests
---
core/bootstrap/image/image.factor | 2 +-
core/classes/classes.factor | 37 ++++++++++++++++++++++++++-----
2 files changed, 33 insertions(+), 6 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index f5f4d70d14..52a2496755 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -349,7 +349,7 @@ M: curry '
[
{
dictionary source-files
- typemap builtins class<map update-map
+ typemap builtins class<map class-map update-map
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
bootstrap-global set
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index e60d3ba223..ad2920e594 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -8,11 +8,12 @@ vectors math quotations combinators sorting effects graphs ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
SYMBOL: typemap
+SYMBOL: class-map
SYMBOL: class<map
SYMBOL: update-map
SYMBOL: builtins
-PREDICATE: word builtin-class
+PREDICATE: class builtin-class
"metaclass" word-prop builtin-class eq? ;
PREDICATE: class tuple-class
@@ -58,6 +59,7 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
+ { [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
@@ -108,11 +110,29 @@ DEFER: (class<)
: lookup-union ( classes -- class )
typemap get at dup empty? [ drop object ] [ first ] if ;
+: lookup-tuple-union ( classes -- class )
+ class-map get at dup empty? [ drop object ] [ first ] if ;
+
+! : (class-or) ( class class -- class )
+! [ flatten-builtin-class ] 2apply union lookup-union ;
+!
+! : (class-and) ( class class -- class )
+! [ flatten-builtin-class ] 2apply intersect lookup-union ;
+
+: class-or-fixup ( set set -- set )
+ union
+ tuple over key?
+ [ [ drop tuple-class? not ] assoc-subset ] when ;
+
: (class-or) ( class class -- class )
- [ flatten-builtin-class ] 2apply union lookup-union ;
+ [ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
+
+: class-and-fixup ( set set -- set )
+ 2dup [ tuple swap key? ] either?
+ [ 2drop H{ { tuple tuple } } ] [ intersect ] if ;
: (class-and) ( class class -- class )
- [ flatten-builtin-class ] 2apply intersect lookup-union ;
+ [ flatten-class ] 2apply class-and-fixup lookup-tuple-union ;
: tuple-class-and ( class1 class2 -- class )
dupd eq? [ drop null ] unless ;
@@ -219,9 +239,16 @@ M: word reset-class drop ;
: typemap- ( class -- )
dup flatten-builtin-class typemap get pop-at ;
+! class-map
+: class-map+ ( class -- )
+ dup flatten-class class-map get push-at ;
+
+: class-map- ( class -- )
+ dup flatten-class class-map get pop-at ;
+
! Class definition
: cache-class ( class -- )
- dup typemap+ dup class<map+ update-map+ ;
+ dup typemap+ dup class-map+ dup class<map+ update-map+ ;
: cache-classes ( assoc -- )
[ drop cache-class ] assoc-each ;
@@ -229,7 +256,7 @@ M: word reset-class drop ;
GENERIC: uncache-class ( class -- )
M: class uncache-class
- dup update-map- dup class<map- typemap- ;
+ dup update-map- dup class<map- dup class-map- typemap- ;
M: word uncache-class drop ;
From 616f96dbb71bb2d524ecc61252b875e5ee50de37 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 19 Mar 2008 23:58:47 -0500
Subject: [PATCH 133/197] Fixes
---
core/classes/classes-tests.factor | 2 ++
core/classes/classes.factor | 12 +++++++-----
core/inference/known-words/known-words.factor | 2 +-
3 files changed, 10 insertions(+), 6 deletions(-)
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index f97f088845..3322c3b043 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -22,6 +22,8 @@ H{ } "s" set
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ null ] [ slice reversed class-and ] unit-test
+[ null ] [ general-t \ f class-and ] unit-test
+[ object ] [ general-t \ f class-or ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index ad2920e594..e47dbd20e5 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -127,12 +127,14 @@ DEFER: (class<)
: (class-or) ( class class -- class )
[ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
-: class-and-fixup ( set set -- set )
- 2dup [ tuple swap key? ] either?
- [ 2drop H{ { tuple tuple } } ] [ intersect ] if ;
-
: (class-and) ( class class -- class )
- [ flatten-class ] 2apply class-and-fixup lookup-tuple-union ;
+ 2dup [ tuple swap class< ] either? [
+ [ flatten-builtin-class ] 2apply
+ intersect lookup-union
+ ] [
+ [ flatten-class ] 2apply
+ intersect lookup-tuple-union
+ ] if ;
: tuple-class-and ( class1 class2 -- class )
dupd eq? [ drop null ] unless ;
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 235c2924bb..08fb56ced7 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -354,7 +354,7 @@ M: object infer-call
\ setenv { object fixnum } { } <effect> set-primitive-effect
-\ (stat) { string } { object object object object } <effect> set-primitive-effect
+\ exists? { string } { object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> set-primitive-effect
From 7084e1982e38e558e2d19c867faec2b967e40eb8 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 19 Mar 2008 23:33:17 -0600
Subject: [PATCH 134/197] builder: update timeout to 2 hours
---
extra/builder/builder.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index ea404d6efa..19734a3266 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -86,7 +86,7 @@ IN: builder
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
- 45 minutes >>timeout ;
+ 120 minutes >>timeout ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
From 0c490161b4241a69e70ac686032905d08bd0c9e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 00:39:32 -0500
Subject: [PATCH 135/197] Fix exists?
---
vm/os-unix.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 29d53487a3..74320288aa 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -44,7 +44,7 @@ void ffi_dlclose(F_DLL *dll)
DEFINE_PRIMITIVE(existsp)
{
struct stat sb;
- box_boolean(stat(unbox_char_string(),&sb) < 0);
+ box_boolean(stat(unbox_char_string(),&sb) >= 0);
}
/* Allocates memory */
From 1c6882b32cc54d57c36296168e4db339a86560c3 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 21 Mar 2008 01:25:45 +1300
Subject: [PATCH 136/197] Rip out packrat stuff It was broken since the
transition to generating compiled quotations. As far as I know, no one was
using packrat-parse anyway. Rework in progress...
---
extra/peg/parsers/parsers.factor | 38 +++++------
extra/peg/peg-tests.factor | 4 --
extra/peg/peg.factor | 106 ++++++++-----------------------
3 files changed, 44 insertions(+), 104 deletions(-)
diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor
index 63e9e9a336..3ccb1e7d10 100755
--- a/extra/peg/parsers/parsers.factor
+++ b/extra/peg/parsers/parsers.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib memoize math.parser match
+ vectors arrays combinators.lib math.parser match
unicode.categories sequences.deep peg peg.private
peg.search math.ranges ;
IN: peg.parsers
@@ -19,26 +19,26 @@ TUPLE: just-parser p1 ;
M: just-parser compile ( parser -- quot )
just-parser-p1 compile just-pattern append ;
-MEMO: just ( parser -- parser )
- just-parser construct-boa init-parser ;
+: just ( parser -- parser )
+ just-parser construct-boa ;
-MEMO: 1token ( ch -- parser ) 1string token ;
+: 1token ( ch -- parser ) 1string token ;
<PRIVATE
-MEMO: (list-of) ( items separator repeat1? -- parser )
+: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
PRIVATE>
-MEMO: list-of ( items separator -- parser )
+: list-of ( items separator -- parser )
hide f (list-of) ;
-MEMO: list-of-many ( items separator -- parser )
+: list-of-many ( items separator -- parser )
hide t (list-of) ;
-MEMO: epsilon ( -- parser ) V{ } token ;
+: epsilon ( -- parser ) V{ } token ;
-MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
+: any-char ( -- parser ) [ drop t ] satisfy ;
<PRIVATE
@@ -47,10 +47,10 @@ MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
PRIVATE>
-MEMO: exactly-n ( parser n -- parser' )
+: exactly-n ( parser n -- parser' )
swap <repetition> seq ;
-MEMO: at-most-n ( parser n -- parser' )
+: at-most-n ( parser n -- parser' )
dup zero? [
2drop epsilon
] [
@@ -58,27 +58,27 @@ MEMO: at-most-n ( parser n -- parser' )
-rot 1- at-most-n 2choice
] if ;
-MEMO: at-least-n ( parser n -- parser' )
+: at-least-n ( parser n -- parser' )
dupd exactly-n swap repeat0 2seq
[ flatten-vectors ] action ;
-MEMO: from-m-to-n ( parser m n -- parser' )
+: from-m-to-n ( parser m n -- parser' )
>r [ exactly-n ] 2keep r> swap - at-most-n 2seq
[ flatten-vectors ] action ;
-MEMO: pack ( begin body end -- parser )
+: pack ( begin body end -- parser )
>r >r hide r> r> hide 3seq [ first ] action ;
-MEMO: surrounded-by ( parser begin end -- parser' )
+: surrounded-by ( parser begin end -- parser' )
[ token ] 2apply swapd pack ;
-MEMO: 'digit' ( -- parser )
+: 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] action ;
-MEMO: 'integer' ( -- parser )
+: 'integer' ( -- parser )
'digit' repeat1 [ 10 digits>integer ] action ;
-MEMO: 'string' ( -- parser )
+: 'string' ( -- parser )
[
[ CHAR: " = ] satisfy hide ,
[ CHAR: " = not ] satisfy repeat0 ,
@@ -97,7 +97,7 @@ MEMO: 'string' ( -- parser )
] action
replace ;
-MEMO: range-pattern ( pattern -- parser )
+: range-pattern ( pattern -- parser )
#! 'pattern' is a set of characters describing the
#! parser to be produced. Any single character in
#! the pattern matches that character. If the pattern
diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index 7a1ce99883..89cc243863 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -4,10 +4,6 @@
USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
IN: peg.tests
-{ 0 1 2 } [
- 0 next-id set-global get-next-id get-next-id get-next-id
-] unit-test
-
{ f } [
"endbegin" "begin" token parse
] unit-test
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 16cf40f884..b3200ec5eb 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib memoize math.parser match
+ vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
words ;
IN: peg
@@ -10,70 +10,14 @@ TUPLE: parse-result remaining ast ;
GENERIC: compile ( parser -- quot )
-: (parse) ( state parser -- result )
+: parse ( state parser -- result )
compile call ;
-
-<PRIVATE
-
-SYMBOL: packrat-cache
SYMBOL: ignore
-SYMBOL: not-in-cache
-
-: not-in-cache? ( result -- ? )
- not-in-cache = ;
: <parse-result> ( remaining ast -- parse-result )
parse-result construct-boa ;
-SYMBOL: next-id
-
-: get-next-id ( -- number )
- next-id get-global 0 or dup 1+ next-id set-global ;
-
-TUPLE: parser id ;
-
-: init-parser ( parser -- parser )
- get-next-id parser construct-boa over set-delegate ;
-
-: from ( slice-or-string -- index )
- dup slice? [ slice-from ] [ drop 0 ] if ;
-
-: get-cached ( input parser -- result )
- [ from ] dip parser-id packrat-cache get at at* [
- drop not-in-cache
- ] unless ;
-
-: put-cached ( result input parser -- )
- parser-id dup packrat-cache get at [
- nip
- ] [
- H{ } clone dup >r swap packrat-cache get set-at r>
- ] if*
- [ from ] dip set-at ;
-
-PRIVATE>
-
-: parse ( input parser -- result )
- packrat-cache get [
- 2dup get-cached dup not-in-cache? [
-! "cache missed: " write over parser-id number>string write " - " write nl ! pick .
- drop
- #! Protect against left recursion blowing the callstack
- #! by storing a failed parse in the cache.
- [ f ] dipd [ put-cached ] 2keep
- [ (parse) dup ] 2keep put-cached
- ] [
-! "cache hit: " write over parser-id number>string write " - " write nl ! pick .
- 2nip
- ] if
- ] [
- (parse)
- ] if ;
-
-: packrat-parse ( input parser -- result )
- H{ } clone packrat-cache [ parse ] with-variable ;
-
<PRIVATE
TUPLE: token-parser symbol ;
@@ -295,17 +239,17 @@ M: delay-parser compile ( parser -- quot )
PRIVATE>
-MEMO: token ( string -- parser )
- token-parser construct-boa init-parser ;
+: token ( string -- parser )
+ token-parser construct-boa ;
: satisfy ( quot -- parser )
- satisfy-parser construct-boa init-parser ;
+ satisfy-parser construct-boa ;
-MEMO: range ( min max -- parser )
- range-parser construct-boa init-parser ;
+: range ( min max -- parser )
+ range-parser construct-boa ;
: seq ( seq -- parser )
- seq-parser construct-boa init-parser ;
+ seq-parser construct-boa ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
@@ -320,7 +264,7 @@ MEMO: range ( min max -- parser )
{ } make seq ; inline
: choice ( seq -- parser )
- choice-parser construct-boa init-parser ;
+ choice-parser construct-boa ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
@@ -334,32 +278,32 @@ MEMO: range ( min max -- parser )
: choice* ( quot -- paser )
{ } make choice ; inline
-MEMO: repeat0 ( parser -- parser )
- repeat0-parser construct-boa init-parser ;
+: repeat0 ( parser -- parser )
+ repeat0-parser construct-boa ;
-MEMO: repeat1 ( parser -- parser )
- repeat1-parser construct-boa init-parser ;
+: repeat1 ( parser -- parser )
+ repeat1-parser construct-boa ;
-MEMO: optional ( parser -- parser )
- optional-parser construct-boa init-parser ;
+: optional ( parser -- parser )
+ optional-parser construct-boa ;
-MEMO: ensure ( parser -- parser )
- ensure-parser construct-boa init-parser ;
+: ensure ( parser -- parser )
+ ensure-parser construct-boa ;
-MEMO: ensure-not ( parser -- parser )
- ensure-not-parser construct-boa init-parser ;
+: ensure-not ( parser -- parser )
+ ensure-not-parser construct-boa ;
: action ( parser quot -- parser )
- action-parser construct-boa init-parser ;
+ action-parser construct-boa ;
-MEMO: sp ( parser -- parser )
- sp-parser construct-boa init-parser ;
+: sp ( parser -- parser )
+ sp-parser construct-boa ;
-MEMO: hide ( parser -- parser )
+: hide ( parser -- parser )
[ drop ignore ] action ;
-MEMO: delay ( quot -- parser )
- delay-parser construct-boa init-parser ;
+: delay ( quot -- parser )
+ delay-parser construct-boa ;
: PEG:
(:) [
From bdda6fc3cbfb4e676d510de75e8ab41cb4c39d2a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 12:10:43 -0500
Subject: [PATCH 137/197] make openbsd compile with NO_UI=1
---
vm/Config.openbsd | 1 +
vm/os-openbsd-x86.32.h | 7 +++++--
vm/os-openbsd.h | 4 ++++
3 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/vm/Config.openbsd b/vm/Config.openbsd
index 61534d4e66..8724ebf378 100644
--- a/vm/Config.openbsd
+++ b/vm/Config.openbsd
@@ -1,4 +1,5 @@
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o
+CC = egcc
CFLAGS += -export-dynamic
LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)
diff --git a/vm/os-openbsd-x86.32.h b/vm/os-openbsd-x86.32.h
index 7e1e4894c2..0617e62c0d 100644
--- a/vm/os-openbsd-x86.32.h
+++ b/vm/os-openbsd-x86.32.h
@@ -1,7 +1,10 @@
+#include <i386/signal.h>
+
INLINE void *openbsd_stack_pointer(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->sc_esp;
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_esp;
}
#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h
index af47f7bcea..21e34c98f8 100644
--- a/vm/os-openbsd.h
+++ b/vm/os-openbsd.h
@@ -1,2 +1,6 @@
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
+
+#ifndef environ
+ extern char **environ;
+#endif
From e20762e0cbab95f087061aac7fe275812dd4d94f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 14:25:08 -0500
Subject: [PATCH 138/197] Fix errors
---
core/debugger/debugger.factor | 6 +++++-
extra/io/encodings/utf16/utf16.factor | 4 ++--
2 files changed, 7 insertions(+), 3 deletions(-)
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index ad2fa14954..cfb696e724 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs threads threads.private init
-kernel.private libc ;
+kernel.private libc io.encodings ;
IN: debugger
GENERIC: error. ( error -- )
@@ -282,6 +282,10 @@ M: thread error-in-thread ( error thread -- )
] bind
] if ;
+M: encode-error summary drop "Character encoding error" ;
+
+M: decode-error summary drop "Character decoding error" ;
+
<PRIVATE
: init-debugger ( -- )
diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor
index 05dc7235f6..290761ec91 100755
--- a/extra/io/encodings/utf16/utf16.factor
+++ b/extra/io/encodings/utf16/utf16.factor
@@ -18,13 +18,13 @@ TUPLE: utf16 ;
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
: double-be ( stream byte -- stream char )
- over stream-read1 prepend-nums ;
+ over stream-read1 swap append-nums ;
: quad-be ( stream byte -- stream char )
double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
- over stream-read1 prepend-nums HEX: 10000 +
+ over stream-read1 swap append-nums HEX: 10000 +
] [ 2drop dup stream-read1 drop replacement-char ] if
] when* ;
From c5eae019300e7339d9acd82db2526cee50b451fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 14:25:23 -0500
Subject: [PATCH 139/197] Small cleanup
---
extra/smtp/smtp.factor | 18 ++++++++++--------
1 file changed, 10 insertions(+), 8 deletions(-)
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index e15a90eda9..58eb42305e 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -8,7 +8,7 @@ calendar.format new-slots accessors ;
IN: smtp
SYMBOL: smtp-domain
-SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
+SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
SYMBOL: read-timeout 1 minutes read-timeout set-global
SYMBOL: esmtp t esmtp set-global
@@ -25,8 +25,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
: crlf "\r\n" write ;
+: command ( string -- ) write crlf flush ;
+
: helo ( -- )
- esmtp get "EHLO " "HELO " ? write host-name write crlf ;
+ esmtp get "EHLO " "HELO " ? host-name append command ;
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
@@ -34,13 +36,13 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
[ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- )
- "MAIL FROM:<" write validate-address write ">" write crlf ;
+ "MAIL FROM:<" swap validate-address ">" 3append command ;
: rcpt-to ( to -- )
- "RCPT TO:<" write validate-address write ">" write crlf ;
+ "RCPT TO:<" swap validate-address ">" 3append command ;
: data ( -- )
- "DATA" write crlf ;
+ "DATA" command ;
: validate-message ( msg -- msg' )
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
@@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
string-lines
validate-message
[ write crlf ] each
- "." write crlf ;
+ "." command ;
: quit ( -- )
- "QUIT" write crlf ;
+ "QUIT" command ;
LOG: smtp-response DEBUG
@@ -85,7 +87,7 @@ LOG: smtp-response DEBUG
readln
dup multiline? [ 3 head process-multiline ] when ;
-: get-ok ( -- ) flush receive-response check-response ;
+: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
dup "\r\n" seq-intersect empty?
From d517bad9ca5bb2e73471f729cdd62843b32e0846 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 14:25:39 -0500
Subject: [PATCH 140/197] Fix race
---
extra/tools/vocabs/vocabs.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index d7e1070666..44a64cc9dd 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -108,6 +108,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
?resource-path utf8 set-file-lines
+ \ (vocab-file-contents) reset-memoized
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
From d82808b3a0f35b7f0b9fc9b397e875023ca8bb71 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 14:53:01 -0500
Subject: [PATCH 141/197] add freebsd 64, untested add openbsd 32/64, untested
---
extra/unix/stat/freebsd/32/32.factor | 30 ++++++++++++++++++++++
extra/unix/stat/freebsd/64/64.factor | 30 ++++++++++++++++++++++
extra/unix/stat/freebsd/freebsd.factor | 33 ++++---------------------
extra/unix/stat/openbsd/32/32.factor | 29 ++++++++++++++++++++++
extra/unix/stat/openbsd/64/64.factor | 29 ++++++++++++++++++++++
extra/unix/stat/openbsd/openbsd.factor | 7 ++++++
extra/unix/types/openbsd/openbsd.factor | 29 ++++++++++++++++++++++
extra/unix/types/types.factor | 4 ++-
8 files changed, 162 insertions(+), 29 deletions(-)
create mode 100644 extra/unix/stat/freebsd/32/32.factor
create mode 100644 extra/unix/stat/freebsd/64/64.factor
create mode 100644 extra/unix/stat/openbsd/32/32.factor
create mode 100644 extra/unix/stat/openbsd/64/64.factor
create mode 100644 extra/unix/stat/openbsd/openbsd.factor
create mode 100755 extra/unix/types/openbsd/openbsd.factor
diff --git a/extra/unix/stat/freebsd/32/32.factor b/extra/unix/stat/freebsd/32/32.factor
new file mode 100644
index 0000000000..a81fc4f02e
--- /dev/null
+++ b/extra/unix/stat/freebsd/32/32.factor
@@ -0,0 +1,30 @@
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! FreeBSD 8.0-CURRENT
+
+C-STRUCT: stat
+ { "__dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "__dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "fflags_t" "st_flags" }
+ { "__uint32_t" "st_gen" }
+ { "__int32_t" "st_lspare" }
+ { "timespec" "st_birthtimespec" }
+! not sure about the padding here.
+ { "__uint32_t" "pad0" }
+ { "__uint32_t" "pad1" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
diff --git a/extra/unix/stat/freebsd/64/64.factor b/extra/unix/stat/freebsd/64/64.factor
new file mode 100644
index 0000000000..75d51cd6ae
--- /dev/null
+++ b/extra/unix/stat/freebsd/64/64.factor
@@ -0,0 +1,30 @@
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! FreeBSD 8.0-CURRENT
+! untested
+
+C-STRUCT: stat
+ { "__dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "__dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "fflags_t" "st_flags" }
+ { "__uint32_t" "st_gen" }
+ { "__int32_t" "st_lspare" }
+ { "timespec" "st_birthtimespec" }
+! not sure about the padding here.
+ { "__uint32_t" "pad0" }
+ { "__uint32_t" "pad1" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/freebsd/freebsd.factor b/extra/unix/stat/freebsd/freebsd.factor
index a81fc4f02e..299d0ecab5 100644
--- a/extra/unix/stat/freebsd/freebsd.factor
+++ b/extra/unix/stat/freebsd/freebsd.factor
@@ -1,30 +1,7 @@
-USING: kernel alien.syntax math ;
-
+USING: layouts combinators vocabs.loader ;
IN: unix.stat
-! FreeBSD 8.0-CURRENT
-
-C-STRUCT: stat
- { "__dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "fflags_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "timespec" "st_birthtimespec" }
-! not sure about the padding here.
- { "__uint32_t" "pad0" }
- { "__uint32_t" "pad1" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
+cell-bits {
+ { 32 [ "unix.stat.freebsd.32" require ] }
+ { 64 [ "unix.stat.freebsd.64" require ] }
+} case
diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor
new file mode 100644
index 0000000000..e4357ba70b
--- /dev/null
+++ b/extra/unix/stat/openbsd/32/32.factor
@@ -0,0 +1,29 @@
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! OpenBSD 4.2
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "int32_t" "st_lspare0" }
+ { "timespec*" "st_atimespec" }
+ { "timespec*" "st_mtimespec" }
+ { "timespec*" "st_ctimespec" }
+ { "off_t" "st_size" }
+ { "int64_t" "st_blocks" }
+ { "u_int32_t" "st_blksize" }
+ { "u_int32_t" "st_flags" }
+ { "u_int32_t" "st_gen" }
+ { "int32_t" "st_lspare1" }
+ { "timespec*" "st_birthtimespec" }
+ { "int64_t" "st_qspare1" }
+ { "int64_t" "st_qspare2" } ;
+
+! FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor
new file mode 100644
index 0000000000..e4357ba70b
--- /dev/null
+++ b/extra/unix/stat/openbsd/64/64.factor
@@ -0,0 +1,29 @@
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! OpenBSD 4.2
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "int32_t" "st_lspare0" }
+ { "timespec*" "st_atimespec" }
+ { "timespec*" "st_mtimespec" }
+ { "timespec*" "st_ctimespec" }
+ { "off_t" "st_size" }
+ { "int64_t" "st_blocks" }
+ { "u_int32_t" "st_blksize" }
+ { "u_int32_t" "st_flags" }
+ { "u_int32_t" "st_gen" }
+ { "int32_t" "st_lspare1" }
+ { "timespec*" "st_birthtimespec" }
+ { "int64_t" "st_qspare1" }
+ { "int64_t" "st_qspare2" } ;
+
+! FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor
new file mode 100644
index 0000000000..0a2312302b
--- /dev/null
+++ b/extra/unix/stat/openbsd/openbsd.factor
@@ -0,0 +1,7 @@
+USING: layouts combinators vocabs.loader ;
+IN: unix.stat
+
+cell-bits {
+ { 32 [ "unix.stat.openbsd.32" require ] }
+ { 64 [ "unix.stat.openbsd.64" require ] }
+} case
diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor
new file mode 100755
index 0000000000..221f9896b0
--- /dev/null
+++ b/extra/unix/types/openbsd/openbsd.factor
@@ -0,0 +1,29 @@
+USING: alien.syntax ;
+IN: unix.types
+
+! OpenBSD 4.2
+
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: int u_int32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint16_t mode_t
+TYPEDEF: __uint16_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor
index f046197d30..59d0c05a87 100644
--- a/extra/unix/types/types.factor
+++ b/extra/unix/types/types.factor
@@ -10,6 +10,8 @@ os
{ "linux" [ "unix.types.linux" require ] }
{ "macosx" [ "unix.types.macosx" require ] }
{ "freebsd" [ "unix.types.freebsd" require ] }
+ { "openbsd" [ "unix.types.openbsd" require ] }
+ { "netbsd" [ "unix.types.netbsd" require ] }
[ drop ]
}
-case
\ No newline at end of file
+case
From 6d36f738eb94a648fd8841c9288fd9f5c329a3c6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 14:54:16 -0500
Subject: [PATCH 142/197] playing around with a cross-platform c program to
write out factor structs
---
misc/grovel.c | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 139 insertions(+)
create mode 100644 misc/grovel.c
diff --git a/misc/grovel.c b/misc/grovel.c
new file mode 100644
index 0000000000..4460c3aab3
--- /dev/null
+++ b/misc/grovel.c
@@ -0,0 +1,139 @@
+#include <stdio.h>
+
+#if defined(__FreeBSD__)
+ #define BSD
+ #define FREEBSD
+ #define UNIX
+#endif
+
+#if defined(__NetBSD__)
+ #define BSD
+ #define NETBSD
+ #define UNIX
+#endif
+
+#if (__OpenBSD__)
+ #define BSD
+ #define OPENBSD
+ #define UNIX
+#endif
+
+#if defined(linux)
+ #define LINUX
+ #define UNIX
+#endif
+
+#if defined(__amd64__) || defined(__x86_64__)
+ #define BIT64
+#else
+ #define BIT32
+#endif
+
+#if defined(UNIX)
+ #include <sys/types.h>
+ #include <sys/stat.h>
+#endif
+
+
+#define BL printf(" ");
+#define QUOT printf("\"");
+#define NL printf("\n");
+#define LB printf("{"); BL
+#define RB BL printf("}");
+#define SEMI printf(";");
+#define grovel(t) printf("TYPEDEF: "); printf("%d", sizeof(t)); BL printf(#t); NL
+#define grovel2impl(t,n) BL BL BL BL LB QUOT printf(#t); QUOT BL QUOT printf((n)); QUOT RB
+#define grovel2(t,n) grovel2impl(t,n) NL
+#define grovel2end(t,n) grovel2impl(t,n) BL SEMI NL
+#define header(os) printf("vvv %s vvv", (os)); NL
+#define footer(os) printf("^^^ %s ^^^", (os)); NL
+#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL
+#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL
+#define struct(n) printf("C-STRUCT: %s\n", (n));
+
+void openbsd_types()
+{
+ header2("openbsd", "types");
+ grovel(dev_t);
+ grovel(gid_t);
+ grovel(ino_t);
+ grovel(int32_t);
+ grovel(int64_t);
+ grovel(mode_t);
+ grovel(nlink_t);
+ grovel(off_t);
+ grovel(struct timespec);
+ grovel(uid_t);
+ footer2("openbsd", "types");
+}
+
+void openbsd_stat()
+{
+ header2("openbsd", "stat");
+ struct("stat");
+ grovel2(dev_t, "st_dev");
+ grovel2(ino_t, "st_ino");
+ grovel2(mode_t, "st_mode");
+ grovel2(nlink_t, "st_nlink");
+ grovel2(uid_t, "st_uid");
+ grovel2(gid_t, "st_gid");
+ grovel2(dev_t, "st_rdev");
+ grovel2(int32_t, "st_lspare0");
+ grovel2(struct timespec, "st_atimespec");
+ grovel2(struct timespec, "st_mtimespec");
+ grovel2(struct timespec, "st_ctimespec");
+ grovel2(off_t, "st_size");
+ grovel2(int64_t, "st_blocks");
+ grovel2(u_int32_t, "st_blksize");
+ grovel2(u_int32_t, "st_flags");
+ grovel2(u_int32_t, "st_gen");
+ grovel2(int32_t, "st_lspare1");
+ grovel2(struct timespec, "st_birthtimespec");
+ grovel2(int64_t, "st_qspare1");
+ grovel2end(int64_t, "st_qspare2");
+ footer2("openbsd", "stat");
+}
+
+void unix_types()
+{
+ grovel(dev_t);
+ grovel(gid_t);
+ grovel(ino_t);
+ grovel(int32_t);
+ grovel(int64_t);
+ grovel(mode_t);
+ grovel(nlink_t);
+ grovel(off_t);
+ grovel(struct timespec);
+ grovel(struct stat);
+ grovel(time_t);
+ grovel(uid_t);
+}
+
+int main() {
+ //grovel(char);
+ //grovel(int);
+ //grovel(uint);
+ //grovel(long);
+ //grovel(ulong);
+ //grovel(long long);
+ //grovel(unsigned long long);
+ //grovel(void*);
+ //grovel(char*);
+
+#ifdef FREEBSD
+ grovel(blkcnt_t);
+ grovel(blksize_t);
+ grovel(fflags_t);
+#endif
+
+#ifdef OPENBSD
+ openbsd_stat();
+ openbsd_types();
+#endif
+
+#ifdef UNIX
+#endif
+
+ return 0;
+}
From 936bd26a3aefe824a52dd7d182b7e7bc4c1b6f9b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:00:49 -0500
Subject: [PATCH 143/197] update core/ to use ERROR:
---
core/alien/alien.factor | 12 ++++++------
core/alien/c-types/c-types.factor | 4 +---
core/combinators/combinators.factor | 8 ++------
core/debugger/debugger.factor | 18 +++++-------------
core/definitions/definitions.factor | 5 +----
core/generic/math/math.factor | 5 +----
core/generic/standard/standard.factor | 5 +----
core/inference/inference-tests.factor | 4 ++--
core/inference/transforms/transforms.factor | 5 +----
core/io/encodings/encodings.factor | 8 ++------
core/io/files/files.factor | 5 +----
core/io/streams/duplex/duplex.factor | 5 ++---
core/libc/libc.factor | 14 ++++----------
core/parser/parser.factor | 19 ++++---------------
core/sequences/sequences.factor | 12 +++---------
core/syntax/syntax.factor | 1 +
core/tuples/tuples.factor | 4 ++--
core/vocabs/vocabs.factor | 7 ++-----
core/words/words.factor | 11 ++++-------
19 files changed, 45 insertions(+), 107 deletions(-)
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index fc89586b68..0afff0c497 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -65,21 +65,21 @@ TUPLE: library path abi dll ;
TUPLE: alien-callback return parameters abi quot xt ;
-TUPLE: alien-callback-error ;
+ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
- \ alien-callback-error construct-empty throw ;
+ alien-callback-error ;
TUPLE: alien-indirect return parameters abi ;
-TUPLE: alien-indirect-error ;
+ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
- \ alien-indirect-error construct-empty throw ;
+ alien-indirect-error ;
TUPLE: alien-invoke library function return parameters ;
-TUPLE: alien-invoke-error library symbol ;
+ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
- 2over \ alien-invoke-error construct-boa throw ;
+ 2over alien-invoke-error ;
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index f1d8abdc1e..d874243d71 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -26,9 +26,7 @@ global [
c-types [ H{ } assoc-like ] change
] bind
-TUPLE: no-c-type name ;
-
-: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
+ERROR: no-c-type name ;
: (c-type) ( name -- type/f )
c-types get-global at dup [
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 53d18b53ca..807b372e1d 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting ;
-TUPLE: no-cond ;
-
-: no-cond ( -- * ) \ no-cond construct-empty throw ;
+ERROR: no-cond ;
: cond ( assoc -- )
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
-TUPLE: no-case ;
-
-: no-case ( -- * ) \ no-case construct-empty throw ;
+ERROR: no-case ;
: case ( obj assoc -- )
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index ad2fa14954..40bc6615fa 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -75,9 +75,7 @@ SYMBOL: error-hook
: try ( quot -- )
[ error-hook get call ] recover ;
-TUPLE: assert got expect ;
-
-: assert ( got expect -- * ) \ assert construct-boa throw ;
+ERROR: assert got expect ;
: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
@@ -86,28 +84,22 @@ TUPLE: assert got expect ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] 2apply min tuck tail >r tail r> ;
-TUPLE: relative-underflow stack ;
-
-: relative-underflow ( before after -- * )
- trim-datastacks nip \ relative-underflow construct-boa throw ;
+ERROR: relative-underflow stack ;
M: relative-underflow summary
drop "Too many items removed from data stack" ;
-TUPLE: relative-overflow stack ;
+ERROR: relative-overflow stack ;
M: relative-overflow summary
drop "Superfluous items pushed to data stack" ;
-: relative-overflow ( before after -- * )
- trim-datastacks drop \ relative-overflow construct-boa throw ;
-
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn {
- { -1 [ relative-underflow ] }
+ { -1 [ trim-datastacks nip relative-underflow ] }
{ 0 [ 2drop ] }
- { 1 [ relative-overflow ] }
+ { 1 [ trim-datastacks drop relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 01f9643cdd..cec5109909 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -3,10 +3,7 @@
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
-TUPLE: no-compilation-unit definition ;
-
-: no-compilation-unit ( definition -- * )
- \ no-compilation-unit construct-boa throw ;
+ERROR: no-compilation-unit definition ;
GENERIC: where ( defspec -- loc )
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index b01fb87f72..46f57a1629 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
dup empty? [ [ dip ] curry [ ] like ] unless
r> append ;
-TUPLE: no-math-method left right generic ;
-
-: no-math-method ( left right generic -- * )
- \ no-math-method construct-boa throw ;
+ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 35161319ef..37f72e7d95 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
-TUPLE: no-method object generic ;
-
-: no-method ( object generic -- * )
- \ no-method construct-boa throw ;
+ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 3c12e388c4..4f5d199264 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -514,10 +514,10 @@ DEFER: an-inline-word
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
-TUPLE: custom-error ;
+ERROR: custom-error ;
[ T{ effect f 0 0 t } ] [
- [ custom-error construct-boa throw ] infer
+ [ custom-error ] infer
] unit-test
: funny-throw throw ; inline
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 240f39218b..a829bad47e 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot )
\ get-slots [ [get-slots] ] 1 define-transform
-TUPLE: duplicated-slots-error names ;
+ERROR: duplicated-slots-error names ;
M: duplicated-slots-error summary
drop "Calling set-slots with duplicate slot setters" ;
-: duplicated-slots-error ( names -- * )
- \ duplicated-slots-error construct-boa throw ;
-
\ set-slots [
dup all-unique?
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 03ea2262a8..610d294bb6 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -18,17 +18,13 @@ GENERIC: <decoder> ( stream decoding -- newstream )
TUPLE: decoder stream code cr ;
-TUPLE: decode-error ;
-
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+ERROR: decode-error ;
GENERIC: <encoder> ( stream encoding -- newstream )
TUPLE: encoder stream code ;
-TUPLE: encode-error ;
-
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
+ERROR: encode-error ;
! Decoding
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 3de7559303..f9116895e4 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: special-directory? ( name -- ? ) { "." ".." } member? ;
-TUPLE: no-parent-directory path ;
-
-: no-parent-directory ( path -- * )
- \ no-parent-directory construct-boa throw ;
+ERROR: no-parent-directory path ;
: parent-directory ( path -- parent )
right-trim-separators {
diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor
index 97e60b4a60..83e991b713 100755
--- a/core/io/streams/duplex/duplex.factor
+++ b/core/io/streams/duplex/duplex.factor
@@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
-TUPLE: check-closed ;
+ERROR: stream-closed-twice ;
: check-closed ( stream -- )
- duplex-stream-closed?
- [ \ check-closed construct-boa throw ] when ;
+ duplex-stream-closed? [ stream-closed-twice ] when ;
: duplex-stream-in+ ( duplex -- stream )
dup check-closed duplex-stream-in ;
diff --git a/core/libc/libc.factor b/core/libc/libc.factor
index e82b244d6d..756d29e551 100755
--- a/core/libc/libc.factor
+++ b/core/libc/libc.factor
@@ -23,20 +23,14 @@ SYMBOL: mallocs
PRIVATE>
-TUPLE: check-ptr ;
+ERROR: bad-ptr ;
: check-ptr ( c-ptr -- c-ptr )
- [ \ check-ptr construct-boa throw ] unless* ;
+ [ bad-ptr ] unless* ;
-TUPLE: double-free ;
+ERROR: double-free ;
-: double-free ( -- * )
- \ double-free construct-empty throw ;
-
-TUPLE: realloc-error ptr size ;
-
-: realloc-error ( alien size -- * )
- \ realloc-error construct-boa throw ;
+ERROR: realloc-error ptr size ;
<PRIVATE
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index fd93479283..887747d7d8 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- )
: scan ( -- str/f ) lexer get parse-token ;
-TUPLE: bad-escape ;
-
-: bad-escape ( -- * )
- \ bad-escape construct-empty throw ;
+ERROR: bad-escape ;
M: bad-escape summary drop "Bad escape code" ;
@@ -215,10 +212,7 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-TUPLE: unexpected want got ;
-
-: unexpected ( want got -- * )
- \ unexpected construct-boa throw ;
+ERROR: unexpected want got ;
PREDICATE: unexpected unexpected-eof
unexpected-got not ;
@@ -294,10 +288,7 @@ M: no-word summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
-TUPLE: staging-violation word ;
-
-: staging-violation ( word -- * )
- \ staging-violation construct-boa throw ;
+ERROR: staging-violation word ;
M: staging-violation summary
drop
@@ -352,9 +343,7 @@ SYMBOL: lexer-factory
] if
] if ;
-TUPLE: bad-number ;
-
-: bad-number ( -- * ) \ bad-number construct-boa throw ;
+ERROR: bad-number ;
: parse-base ( parsed base -- parsed )
scan swap base> [ bad-number ] unless* parsed ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 3c69bfa41c..14674ba2f2 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
-TUPLE: bounds-error index seq ;
-
-: bounds-error ( n seq -- * )
- \ bounds-error construct-boa throw ;
+ERROR: bounds-error index seq ;
: bounds-check ( n seq -- n seq )
2dup bounds-check? [ bounds-error ] unless ; inline
MIXIN: immutable-sequence
-TUPLE: immutable seq ;
-
-: immutable ( seq -- * ) \ immutable construct-boa throw ;
+ERROR: immutable seq ;
M: immutable-sequence set-nth immutable ;
@@ -190,8 +185,7 @@ TUPLE: slice from to seq ;
: collapse-slice ( m n slice -- m' n' seq )
dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
-TUPLE: slice-error reason ;
-: slice-error ( str -- * ) \ slice-error construct-boa throw ;
+ERROR: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 8cc9211599..843f372542 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -165,6 +165,7 @@ IN: bootstrap.syntax
"ERROR:" [
CREATE-CLASS dup ";" parse-tokens define-tuple-class
+ dup save-location
dup [ construct-boa throw ] curry define
] define-syntax
diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor
index e48a803659..6f94d034fa 100755
--- a/core/tuples/tuples.factor
+++ b/core/tuples/tuples.factor
@@ -87,11 +87,11 @@ PRIVATE>
2dup delegate-slot-spec add* "slots" set-word-prop
define-slots ;
-TUPLE: check-tuple class ;
+ERROR: no-tuple-class class ;
: check-tuple ( class -- )
dup tuple-class?
- [ drop ] [ \ check-tuple construct-boa throw ] if ;
+ [ drop ] [ no-tuple-class ] if ;
: define-tuple-class ( class slots -- )
2dup check-shape
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 807e08f73b..9cf5a39772 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -60,16 +60,13 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
-TUPLE: no-vocab name ;
-
-: no-vocab ( name -- * )
- vocab-name \ no-vocab construct-boa throw ;
+ERROR: no-vocab name ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
- dup vocab [ ] [ no-vocab ] ?if ;
+ dup vocab [ ] [ vocab-name no-vocab ] ?if ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
diff --git a/core/words/words.factor b/core/words/words.factor
index a36cca00ac..de253e6fee 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ;
M: word definition word-def ;
-TUPLE: undefined ;
-
-: undefined ( -- * ) \ undefined construct-empty throw ;
+ERROR: undefined ;
PREDICATE: word deferred ( obj -- ? )
word-def [ undefined ] = ;
@@ -189,12 +187,11 @@ M: word subwords drop f ;
[ ] [ no-vocab ] ?if
set-at ;
-TUPLE: check-create name vocab ;
+ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
- 2dup [ string? ] both? [
- \ check-create construct-boa throw
- ] unless ;
+ 2dup [ string? ] both?
+ [ bad-create ] unless ;
: create ( name vocab -- word )
check-create 2dup lookup
From 87b13afb9b10f0f27687cf3c5346a4a33685c2f3 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@forth.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 15:06:22 -0500
Subject: [PATCH 144/197] change old mt to random-generator for deploy
---
extra/tools/deploy/shaker/shaker.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 44fb15ac7e..d31a3460ca 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -19,7 +19,7 @@ QUALIFIED: libc.private
QUALIFIED: libc.private
QUALIFIED: listener
QUALIFIED: prettyprint.config
-QUALIFIED: random.private
+QUALIFIED: random
QUALIFIED: source-files
QUALIFIED: threads
QUALIFIED: vocabs
@@ -108,7 +108,7 @@ IN: tools.deploy.shaker
: stripped-globals ( -- seq )
[
- random.private:mt ,
+ random:random-generator ,
{
bootstrap.stage2:bootstrap-time
From e5392461315b7ca216627b5336c2f33b33119f28 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:11:27 -0500
Subject: [PATCH 145/197] fix stat on openbsd32
---
extra/unix/stat/openbsd/32/32.factor | 8 ++++----
extra/unix/stat/openbsd/64/64.factor | 2 +-
extra/unix/stat/stat.factor | 3 ++-
extra/unix/types/types.factor | 1 -
4 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor
index e4357ba70b..521735c9b4 100644
--- a/extra/unix/stat/openbsd/32/32.factor
+++ b/extra/unix/stat/openbsd/32/32.factor
@@ -12,9 +12,9 @@ C-STRUCT: stat
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
- { "timespec*" "st_atimespec" }
- { "timespec*" "st_mtimespec" }
- { "timespec*" "st_ctimespec" }
+ { "timespec*" "st_atim" }
+ { "timespec*" "st_mtim" }
+ { "timespec*" "st_ctim" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
@@ -25,5 +25,5 @@ C-STRUCT: stat
{ "int64_t" "st_qspare1" }
{ "int64_t" "st_qspare2" } ;
-! FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor
index e4357ba70b..752574a43a 100644
--- a/extra/unix/stat/openbsd/64/64.factor
+++ b/extra/unix/stat/openbsd/64/64.factor
@@ -25,5 +25,5 @@ C-STRUCT: stat
{ "int64_t" "st_qspare1" }
{ "int64_t" "st_qspare2" } ;
-! FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor
index e0a6a9fb76..f7432332b9 100644
--- a/extra/unix/stat/stat.factor
+++ b/extra/unix/stat/stat.factor
@@ -63,7 +63,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
{ "linux" [ "unix.stat.linux" require ] }
{ "macosx" [ "unix.stat.macosx" require ] }
{ "freebsd" [ "unix.stat.freebsd" require ] }
- [ drop ]
+ { "netbsd" [ "unix.stat.netbsd" require ] }
+ { "openbsd" [ "unix.stat.openbsd" require ] }
}
case
>>
diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor
index 59d0c05a87..ed2dbd5ba8 100644
--- a/extra/unix/types/types.factor
+++ b/extra/unix/types/types.factor
@@ -12,6 +12,5 @@ os
{ "freebsd" [ "unix.types.freebsd" require ] }
{ "openbsd" [ "unix.types.openbsd" require ] }
{ "netbsd" [ "unix.types.netbsd" require ] }
- [ drop ]
}
case
From c996c092fc4c03067a0695f1eee1a59798094746 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:24:30 -0500
Subject: [PATCH 146/197] start a unit test file for stat
---
extra/unix/stat/stat-tests.factor | 8 ++++++++
1 file changed, 8 insertions(+)
create mode 100644 extra/unix/stat/stat-tests.factor
diff --git a/extra/unix/stat/stat-tests.factor b/extra/unix/stat/stat-tests.factor
new file mode 100644
index 0000000000..02ae29ae5a
--- /dev/null
+++ b/extra/unix/stat/stat-tests.factor
@@ -0,0 +1,8 @@
+USING: kernel tools.test files.unique ;
+IN: unix.stat.tests
+
+[ 123 ] [
+ 123 CHAR: a <repetition> [
+ write
+ ] with-unique-file file-size>>
+] unit-test
From 02727576c2eeb046f1fc6118767d5a21281cf1ca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 15:30:59 -0500
Subject: [PATCH 147/197] New slots are now in the core
---
core/alien/structs/structs-docs.factor | 61 +++++++-
core/alien/structs/structs.factor | 2 +-
core/bootstrap/primitives.factor | 9 +-
core/slots/deprecated/deprecated.factor | 95 ++++++++++++
core/slots/slots-docs.factor | 61 ++------
core/slots/slots.factor | 146 +++++++-----------
core/tuples/tuples.factor | 6 +-
core/vocabs/vocabs.factor | 3 +-
extra/cairo/lib/lib.factor | 2 +-
extra/cairo/png/png.factor | 2 +-
extra/calendar/calendar.factor | 2 +-
.../distributed/distributed.factor | 2 +-
extra/db/db.factor | 2 +-
extra/db/postgresql/lib/lib.factor | 2 +-
extra/digraphs/digraphs.factor | 2 +-
extra/help/help.factor | 4 -
extra/help/markup/markup.factor | 57 -------
extra/http/http.factor | 2 +-
extra/http/server/actions/actions.factor | 2 +-
extra/http/server/auth/basic/basic.factor | 2 +-
extra/http/server/auth/login/login.factor | 2 +-
.../server/auth/providers/assoc/assoc.factor | 2 +-
extra/http/server/auth/providers/db/db.factor | 2 +-
.../server/auth/providers/providers.factor | 2 +-
extra/http/server/callbacks/callbacks.factor | 2 +-
.../server/components/components-tests.factor | 2 +-
.../http/server/components/components.factor | 2 +-
extra/http/server/db/db.factor | 2 +-
extra/http/server/server-tests.factor | 2 +-
extra/http/server/server.factor | 2 +-
extra/http/server/sessions/sessions.factor | 2 +-
.../sessions/storage/assoc/assoc.factor | 2 +-
.../http/server/sessions/storage/db/db.factor | 2 +-
extra/http/server/static/static.factor | 2 +-
.../http/server/validators/validators.factor | 2 +-
extra/io/launcher/launcher.factor | 2 +-
extra/io/paths/paths.factor | 2 +-
extra/io/unix/launcher/launcher.factor | 2 +-
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/pipes/pipes.factor | 2 +-
extra/locals/locals.factor | 2 +-
.../blum-blum-shub/blum-blum-shub.factor | 2 +-
extra/random/dummy/dummy.factor | 2 +-
.../mersenne-twister/mersenne-twister.factor | 2 +-
extra/semantic-db/hierarchy/hierarchy.factor | 2 +-
extra/semantic-db/semantic-db.factor | 2 +-
extra/serialize/serialize.factor | 2 +-
extra/smtp/smtp.factor | 2 +-
extra/windows/com/syntax/syntax.factor | 2 +-
49 files changed, 275 insertions(+), 247 deletions(-)
create mode 100755 core/slots/deprecated/deprecated.factor
mode change 100644 => 100755 core/slots/slots-docs.factor
mode change 100644 => 100755 extra/cairo/lib/lib.factor
mode change 100644 => 100755 extra/cairo/png/png.factor
mode change 100644 => 100755 extra/digraphs/digraphs.factor
mode change 100644 => 100755 extra/random/blum-blum-shub/blum-blum-shub.factor
mode change 100644 => 100755 extra/random/dummy/dummy.factor
mode change 100644 => 100755 extra/semantic-db/hierarchy/hierarchy.factor
mode change 100644 => 100755 extra/semantic-db/semantic-db.factor
mode change 100644 => 100755 extra/windows/com/syntax/syntax.factor
diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor
index fe19f29766..6c7775de2b 100755
--- a/core/alien/structs/structs-docs.factor
+++ b/core/alien/structs/structs-docs.factor
@@ -1,6 +1,65 @@
IN: alien.structs
USING: alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays ;
+alien.syntax sequences io arrays slots.deprecated
+kernel words slots assocs namespaces ;
+
+! Deprecated code
+: ($spec-reader-values) ( slot-spec class -- element )
+ dup ?word-name swap 2array
+ over slot-spec-name
+ rot slot-spec-type 2array 2array
+ [ { $instance } swap add ] assoc-map ;
+
+: $spec-reader-values ( slot-spec class -- )
+ ($spec-reader-values) $values ;
+
+: $spec-reader-description ( slot-spec class -- )
+ [
+ "Outputs the value stored in the " ,
+ { $snippet } rot slot-spec-name add ,
+ " slot of " ,
+ { $instance } swap add ,
+ " instance." ,
+ ] { } make $description ;
+
+: $spec-reader ( reader slot-specs class -- )
+ >r slot-of-reader r>
+ over [
+ 2dup $spec-reader-values
+ 2dup $spec-reader-description
+ ] when 2drop ;
+
+GENERIC: slot-specs ( help-type -- specs )
+
+M: word slot-specs "slots" word-prop ;
+
+: $slot-reader ( reader -- )
+ first dup "reading" word-prop [ slot-specs ] keep
+ $spec-reader ;
+
+: $spec-writer-values ( slot-spec class -- )
+ ($spec-reader-values) reverse $values ;
+
+: $spec-writer-description ( slot-spec class -- )
+ [
+ "Stores a new value to the " ,
+ { $snippet } rot slot-spec-name add ,
+ " slot of " ,
+ { $instance } swap add ,
+ " instance." ,
+ ] { } make $description ;
+
+: $spec-writer ( writer slot-specs class -- )
+ >r slot-of-writer r>
+ over [
+ 2dup $spec-writer-values
+ 2dup $spec-writer-description
+ dup ?word-name 1array $side-effects
+ ] when 2drop ;
+
+: $slot-writer ( reader -- )
+ first dup "writing" word-prop [ slot-specs ] keep
+ $spec-writer ;
M: string slot-specs c-type struct-type-fields ;
diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor
index aec09621cb..e5de8ab83e 100755
--- a/core/alien/structs/structs.factor
+++ b/core/alien/structs/structs.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces parser sequences strings words libc slots
-alien.c-types cpu.architecture ;
+slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 354ea672eb..825ee05584 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes tuples
kernel.private vocabs vocabs.loader source-files definitions
-slots classes.union compiler.units bootstrap.image.private
-io.files ;
+slots.deprecated classes.union compiler.units
+bootstrap.image.private io.files ;
+IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@@ -32,6 +32,9 @@ H{ } clone dictionary set
H{ } clone changed-words set
H{ } clone root-cache set
+! Vocabulary for slot accessors
+"accessors" create-vocab drop
+
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
[ drop { } ] recompile-hook set
diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor
new file mode 100755
index 0000000000..cc93aeeff2
--- /dev/null
+++ b/core/slots/deprecated/deprecated.factor
@@ -0,0 +1,95 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math namespaces
+sequences strings words effects generic generic.standard
+classes slots.private combinators slots ;
+IN: slots.deprecated
+
+: reader-effect ( class spec -- effect )
+ >r ?word-name 1array r> slot-spec-name 1array <effect> ;
+
+PREDICATE: word slot-reader "reading" word-prop >boolean ;
+
+: set-reader-props ( class spec -- )
+ 2dup reader-effect
+ over slot-spec-reader
+ swap "declared-effect" set-word-prop
+ slot-spec-reader swap "reading" set-word-prop ;
+
+: define-reader ( class spec -- )
+ dup slot-spec-reader [
+ [ set-reader-props ] 2keep
+ dup slot-spec-offset
+ over slot-spec-reader
+ rot slot-spec-type reader-quot
+ define-slot-word
+ ] [
+ 2drop
+ ] if ;
+
+: writer-effect ( class spec -- effect )
+ slot-spec-name swap ?word-name 2array 0 <effect> ;
+
+PREDICATE: word slot-writer "writing" word-prop >boolean ;
+
+: set-writer-props ( class spec -- )
+ 2dup writer-effect
+ over slot-spec-writer
+ swap "declared-effect" set-word-prop
+ slot-spec-writer swap "writing" set-word-prop ;
+
+: define-writer ( class spec -- )
+ dup slot-spec-writer [
+ [ set-writer-props ] 2keep
+ dup slot-spec-offset
+ swap slot-spec-writer
+ [ set-slot ]
+ define-slot-word
+ ] [
+ 2drop
+ ] if ;
+
+: define-slot ( class spec -- )
+ 2dup define-reader define-writer ;
+
+: define-slots ( class specs -- )
+ [ define-slot ] with each ;
+
+: reader-word ( class name vocab -- word )
+ >r >r "-" r> 3append r> create ;
+
+: writer-word ( class name vocab -- word )
+ >r [ swap "set-" % % "-" % % ] "" make r> create ;
+
+: (simple-slot-word) ( class name -- class name vocab )
+ over word-vocabulary >r >r word-name r> r> ;
+
+: simple-reader-word ( class name -- word )
+ (simple-slot-word) reader-word ;
+
+: simple-writer-word ( class name -- word )
+ (simple-slot-word) writer-word ;
+
+: short-slot ( class name # -- spec )
+ >r object bootstrap-word over r> f f <slot-spec>
+ 2over simple-reader-word over set-slot-spec-reader
+ -rot simple-writer-word over set-slot-spec-writer ;
+
+: long-slot ( spec # -- spec )
+ >r [ dup array? [ first2 create ] when ] map first4 r>
+ -rot <slot-spec> ;
+
+: simple-slots ( class slots base -- specs )
+ over length [ + ] with map [
+ {
+ { [ over not ] [ 2drop f ] }
+ { [ over string? ] [ >r dupd r> short-slot ] }
+ { [ over array? ] [ long-slot ] }
+ } cond
+ ] 2map [ ] subset nip ;
+
+: slot-of-reader ( reader specs -- spec/f )
+ [ slot-spec-reader eq? ] with find nip ;
+
+: slot-of-writer ( writer specs -- spec/f )
+ [ slot-spec-writer eq? ] with find nip ;
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
old mode 100644
new mode 100755
index d57c4053e6..8a1fb16fa9
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -12,15 +12,11 @@ $nl
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
-{ $subsection slot-spec-reader }
-{ $subsection slot-spec-writer }
-"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:"
-{ $subsection slot-of-reader }
-{ $subsection slot-of-writer }
-"Reader and writer words form classes:"
-{ $subsection slot-reader }
-{ $subsection slot-writer }
-"Slot readers and writers type check, then call unsafe primitives:"
+{ $subsection reader-word }
+{ $subsection writer-word }
+{ $subsection setter-word }
+{ $subsection changer-word }
+"Slot methods type check, then call unsafe primitives:"
{ $subsection slot }
{ $subsection set-slot } ;
@@ -59,17 +55,7 @@ $low-level-note ;
HELP: reader-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
-
-HELP: reader-quot
-{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } }
-{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ;
-
-HELP: slot-reader
-{ $class-description "The class of slot reader words." }
-{ $examples
- { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
-} ;
+{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
{ $values { "class" class } { "spec" slot-spec } }
@@ -80,32 +66,21 @@ HELP: writer-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
-HELP: slot-writer
-{ $class-description "The class of slot writer words." }
-{ $examples
- { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
-} ;
-
HELP: define-writer
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
-HELP: define-slot
+HELP: define-slot-methods
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
$low-level-note ;
-HELP: define-slots
+HELP: define-accessors
{ $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Defines a set of slot reader/writer words." }
+{ $description "Defines slot methods." }
$low-level-note ;
-HELP: simple-slots
-{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
-{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ;
-
HELP: slot ( obj m -- value )
{ $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } }
{ $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
@@ -116,18 +91,6 @@ HELP: set-slot ( value obj n -- )
{ $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
{ $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
-HELP: slot-of-reader
-{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ;
-
-HELP: slot-of-writer
-{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ;
-
-HELP: reader-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
-
-HELP: writer-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
+HELP: slot-named
+{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
+{ $description "Outputs the " { $link slot-spec } " with the given name." } ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 7e9046573f..025cf97420 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -16,9 +16,6 @@ C: <slot-spec> slot-spec
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
-: reader-effect ( class spec -- effect )
- >r ?word-name 1array r> slot-spec-name 1array <effect> ;
-
: reader-quot ( decl -- quot )
[
\ slot ,
@@ -26,91 +23,62 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
-PREDICATE: word slot-reader "reading" word-prop >boolean ;
-
-: set-reader-props ( class spec -- )
- 2dup reader-effect
- over slot-spec-reader
- swap "declared-effect" set-word-prop
- slot-spec-reader swap "reading" set-word-prop ;
-
-: define-reader ( class spec -- )
- dup slot-spec-reader [
- [ set-reader-props ] 2keep
- dup slot-spec-offset
- over slot-spec-reader
- rot slot-spec-type reader-quot
- define-slot-word
- ] [
- 2drop
- ] if ;
-
-: writer-effect ( class spec -- effect )
- slot-spec-name swap ?word-name 2array 0 <effect> ;
-
-PREDICATE: word slot-writer "writing" word-prop >boolean ;
-
-: set-writer-props ( class spec -- )
- 2dup writer-effect
- over slot-spec-writer
- swap "declared-effect" set-word-prop
- slot-spec-writer swap "writing" set-word-prop ;
-
-: define-writer ( class spec -- )
- dup slot-spec-writer [
- [ set-writer-props ] 2keep
- dup slot-spec-offset
- swap slot-spec-writer
- [ set-slot ]
- define-slot-word
- ] [
- 2drop
- ] if ;
-
-: define-slot ( class spec -- )
- 2dup define-reader define-writer ;
-
-: define-slots ( class specs -- )
- [ define-slot ] with each ;
-
-: reader-word ( class name vocab -- word )
- >r >r "-" r> 3append r> create ;
-
-: writer-word ( class name vocab -- word )
- >r [ swap "set-" % % "-" % % ] "" make r> create ;
-
-: (simple-slot-word) ( class name -- class name vocab )
- over word-vocabulary >r >r word-name r> r> ;
-
-: simple-reader-word ( class name -- word )
- (simple-slot-word) reader-word ;
-
-: simple-writer-word ( class name -- word )
- (simple-slot-word) writer-word ;
-
-: short-slot ( class name # -- spec )
- >r object bootstrap-word over r> f f <slot-spec>
- 2over simple-reader-word over set-slot-spec-reader
- -rot simple-writer-word over set-slot-spec-writer ;
-
-: long-slot ( spec # -- spec )
- >r [ dup array? [ first2 create ] when ] map first4 r>
- -rot <slot-spec> ;
-
-: simple-slots ( class slots base -- specs )
- over length [ + ] with map [
- {
- { [ over not ] [ 2drop f ] }
- { [ over string? ] [ >r dupd r> short-slot ] }
- { [ over array? ] [ long-slot ] }
- } cond
- ] 2map [ ] subset nip ;
-
-: slot-of-reader ( reader specs -- spec/f )
- [ slot-spec-reader eq? ] with find nip ;
-
-: slot-of-writer ( writer specs -- spec/f )
- [ slot-spec-writer eq? ] with find nip ;
-
: slot-named ( string specs -- spec/f )
[ slot-spec-name = ] with find nip ;
+
+: create-accessor ( name effect -- word )
+ >r "accessors" create dup r>
+ "declared-effect" set-word-prop ;
+
+: reader-effect T{ effect f { "object" } { "value" } } ; inline
+
+: reader-word ( name -- word )
+ ">>" append reader-effect create-accessor ;
+
+: define-reader ( class slot name -- )
+ reader-word object reader-quot define-slot-word ;
+
+: writer-effect T{ effect f { "value" "object" } { } } ; inline
+
+: writer-word ( name -- word )
+ "(>>" swap ")" 3append writer-effect create-accessor ;
+
+: define-writer ( class slot name -- )
+ writer-word [ set-slot ] define-slot-word ;
+
+: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
+
+: setter-word ( name -- word )
+ ">>" prepend setter-effect create-accessor ;
+
+: define-setter ( name -- )
+ dup setter-word dup deferred? [
+ [ \ over , swap writer-word , ] [ ] make define-inline
+ ] [ 2drop ] if ;
+
+: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
+
+: changer-word ( name -- word )
+ "change-" prepend changer-effect create-accessor ;
+
+: define-changer ( name -- )
+ dup changer-word dup deferred? [
+ [
+ [ over >r >r ] %
+ over reader-word ,
+ [ r> call r> swap ] %
+ swap setter-word ,
+ ] [ ] make define-inline
+ ] [ 2drop ] if ;
+
+: define-slot-methods ( class slot name -- )
+ dup define-changer
+ dup define-setter
+ 3dup define-reader
+ define-writer ;
+
+: define-accessors ( class specs -- )
+ [
+ dup slot-spec-offset swap slot-spec-name
+ define-slot-methods
+ ] with each ;
diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor
index e48a803659..d2d3d01c37 100755
--- a/core/tuples/tuples.factor
+++ b/core/tuples/tuples.factor
@@ -3,7 +3,8 @@
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
-classes classes.private slots slots.private compiler.units ;
+classes classes.private slots slots.deprecated slots.private
+compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
@@ -85,7 +86,8 @@ PRIVATE>
dupd 4 simple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop
- define-slots ;
+ 2dup define-slots
+ define-accessors ;
TUPLE: check-tuple class ;
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 807e08f73b..cf7018b652 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -7,8 +7,7 @@ IN: vocabs
SYMBOL: dictionary
TUPLE: vocab
-name root
-words
+name words
main help
source-loaded? docs-loaded? ;
diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor
old mode 100644
new mode 100755
index 9e226ee47a..1b969978a3
--- a/extra/cairo/lib/lib.factor
+++ b/extra/cairo/lib/lib.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
-kernel libc locals math combinators.cleave shuffle new-slots
+kernel libc locals math combinators.cleave shuffle
accessors ;
IN: cairo.lib
diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
old mode 100644
new mode 100755
index b9da14088c..55828cde9c
--- a/extra/cairo/png/png.factor
+++ b/extra/cairo/png/png.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.cleave kernel new-slots
+USING: arrays combinators.cleave kernel
accessors math ui.gadgets ui.render opengl.gl byte-arrays
namespaces opengl cairo.ffi cairo.lib ;
IN: cairo.png
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 7347363e5b..06425975d4 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -3,7 +3,7 @@
USING: arrays kernel math math.functions namespaces sequences
strings tuples system vocabs.loader calendar.backend threads
-new-slots accessors combinators locals ;
+accessors combinators locals ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor
index c0787a96a2..c007e9f152 100755
--- a/extra/concurrency/distributed/distributed.factor
+++ b/extra/concurrency/distributed/distributed.factor
@@ -3,7 +3,7 @@
USING: serialize sequences concurrency.messaging
threads io io.server qualified arrays
namespaces kernel io.encodings.binary combinators.cleave
-new-slots accessors ;
+accessors ;
QUALIFIED: io.sockets
IN: concurrency.distributed
diff --git a/extra/db/db.factor b/extra/db/db.factor
index ac46be4422..f9e946fc20 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words strings
-tools.walker new-slots accessors ;
+tools.walker accessors ;
IN: db
TUPLE: db
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index 928b51dc59..270be886c5 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -4,7 +4,7 @@ USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser
combinators combinators.cleave libc shuffle calendar.format
-byte-arrays destructors prettyprint new-slots accessors
+byte-arrays destructors prettyprint accessors
strings serialize io.encodings.binary io.streams.byte-array ;
IN: db.postgresql.lib
diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor
old mode 100644
new mode 100755
index 5c6fa9b2a1..1776c916ad
--- a/extra/digraphs/digraphs.factor
+++ b/extra/digraphs/digraphs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel new-slots sequences vectors ;
+USING: accessors assocs kernel sequences vectors ;
IN: digraphs
TUPLE: digraph ;
diff --git a/extra/help/help.factor b/extra/help/help.factor
index 4cb8cfe854..9e4d02802b 100755
--- a/extra/help/help.factor
+++ b/extra/help/help.factor
@@ -25,10 +25,6 @@ GENERIC: word-help* ( word -- content )
M: word word-help* drop f ;
-M: slot-reader word-help* drop \ $slot-reader ;
-
-M: slot-writer word-help* drop \ $slot-writer ;
-
M: predicate word-help* drop \ $predicate ;
: all-articles ( -- seq )
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 47a40d6948..9c3615f629 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -296,63 +296,6 @@ M: string ($instance)
{ $link with-pprint } " combinator."
} $notes ;
-: ($spec-reader-values) ( slot-spec class -- element )
- dup ?word-name swap 2array
- over slot-spec-name
- rot slot-spec-type 2array 2array
- [ { $instance } swap add ] assoc-map ;
-
-: $spec-reader-values ( slot-spec class -- )
- ($spec-reader-values) $values ;
-
-: $spec-reader-description ( slot-spec class -- )
- [
- "Outputs the value stored in the " ,
- { $snippet } rot slot-spec-name add ,
- " slot of " ,
- { $instance } swap add ,
- " instance." ,
- ] { } make $description ;
-
-: $spec-reader ( reader slot-specs class -- )
- >r slot-of-reader r>
- over [
- 2dup $spec-reader-values
- 2dup $spec-reader-description
- ] when 2drop ;
-
-GENERIC: slot-specs ( help-type -- specs )
-
-M: word slot-specs "slots" word-prop ;
-
-: $slot-reader ( reader -- )
- first dup "reading" word-prop [ slot-specs ] keep
- $spec-reader ;
-
-: $spec-writer-values ( slot-spec class -- )
- ($spec-reader-values) reverse $values ;
-
-: $spec-writer-description ( slot-spec class -- )
- [
- "Stores a new value to the " ,
- { $snippet } rot slot-spec-name add ,
- " slot of " ,
- { $instance } swap add ,
- " instance." ,
- ] { } make $description ;
-
-: $spec-writer ( writer slot-specs class -- )
- >r slot-of-writer r>
- over [
- 2dup $spec-writer-values
- 2dup $spec-writer-description
- dup ?word-name 1array $side-effects
- ] when 2drop ;
-
-: $slot-writer ( reader -- )
- first dup "writing" word-prop [ slot-specs ] keep
- $spec-writer ;
-
GENERIC: elements* ( elt-type element -- )
M: simple-element elements* [ elements* ] with each ;
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 421a409639..0bb983c53d 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -3,7 +3,7 @@
USING: fry hashtables io io.streams.string kernel math
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
-combinators vectors sorting new-slots accessors calendar
+combinators vectors sorting accessors calendar
calendar.format quotations arrays combinators.cleave
combinators.lib byte-arrays ;
IN: http
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 287f6dd907..f39980037d 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors new-slots sequences kernel assocs combinators
+USING: accessors sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations locals ;
IN: http.server.actions
diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor
index 2ea74febba..04c0e62d07 100755
--- a/extra/http/server/auth/basic/basic.factor
+++ b/extra/http/server/auth/basic/basic.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors new-slots quotations assocs kernel splitting
+USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http sequences ;
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 275fb0ff63..8c61a9dd47 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors new-slots quotations assocs kernel splitting
+USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http.server.actions http.server.components http.server.sessions
diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor
index e8ab908406..18ec8da62a 100755
--- a/extra/http/server/auth/providers/assoc/assoc.factor
+++ b/extra/http/server/auth/providers/assoc/assoc.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.auth.providers.assoc
-USING: new-slots accessors assocs kernel
+USING: accessors assocs kernel
http.server.auth.providers ;
TUPLE: users-in-memory assoc ;
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
index aec64d3384..1e84e544b8 100755
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types new-slots accessors
+USING: db db.tuples db.types accessors
http.server.auth.providers kernel continuations
singleton ;
IN: http.server.auth.providers.db
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index cdad4815a6..eda3babf0f 100755
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel new-slots accessors random math.parser locals
+USING: kernel accessors random math.parser locals
sequences math crypto.sha2 ;
IN: http.server.auth.providers
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
index eb264279cb..ab629ae236 100755
--- a/extra/http/server/callbacks/callbacks.factor
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -2,7 +2,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html http http.server io kernel math namespaces
-continuations calendar sequences assocs new-slots hashtables
+continuations calendar sequences assocs hashtables
accessors arrays alarms quotations combinators
combinators.cleave fry assocs.lib ;
IN: http.server.callbacks
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
index 09d31202c5..d372865b7e 100755
--- a/extra/http/server/components/components-tests.factor
+++ b/extra/http/server/components/components-tests.factor
@@ -1,6 +1,6 @@
IN: http.server.components.tests
USING: http.server.components http.server.validators
-namespaces tools.test kernel accessors new-slots
+namespaces tools.test kernel accessors
tuple-syntax mirrors http.server.actions ;
validation-failed? off
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index 8581335f3d..516abe79a5 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: new-slots html.elements http.server.validators accessors
+USING: html.elements http.server.validators accessors
namespaces kernel io math.parser assocs classes words tuples
arrays sequences io.files http.server.templating.fhtml
http.server.actions splitting mirrors hashtables
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
index 4a2315b4fd..0b2e9bccc3 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: db http.server kernel new-slots accessors
+USING: db http.server kernel accessors
continuations namespaces destructors combinators.cleave ;
IN: http.server.db
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
index e992a1b6fa..346a31f30f 100755
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -1,5 +1,5 @@
USING: http.server tools.test kernel namespaces accessors
-new-slots io http math sequences assocs ;
+io http math sequences assocs ;
IN: http.server.tests
[
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 7448752c60..6b3ae52730 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
-new-slots html.elements accessors math.parser combinators.lib
+html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index f45f10d25f..aea1bef930 100755
--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
-new-slots accessors http http.server
+accessors http http.server
http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry combinators.cleave
html.elements symbols continuations destructors ;
diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor
index 1339e3c867..f72f34e4d2 100755
--- a/extra/http/server/sessions/storage/assoc/assoc.factor
+++ b/extra/http/server/sessions/storage/assoc/assoc.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs assocs.lib new-slots accessors
+USING: assocs assocs.lib accessors
http.server.sessions.storage combinators.cleave alarms kernel
fry http.server ;
IN: http.server.sessions.storage.assoc
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
index 07cd22bc62..4d87aea5a3 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs new-slots accessors http.server.sessions.storage
+USING: assocs accessors http.server.sessions.storage
alarms kernel http.server db.tuples db.types singleton
combinators.cleave math.parser ;
IN: http.server.sessions.storage.db
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index b001242776..37c3a63d76 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -3,7 +3,7 @@
USING: calendar html io io.files kernel math math.parser http
http.server namespaces parser sequences strings assocs
hashtables debugger http.mime sorting html.elements logging
-calendar.format new-slots accessors io.encodings.binary
+calendar.format accessors io.encodings.binary
combinators.cleave fry ;
IN: http.server.static
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
index f2d1f568e6..b3710f6439 100755
--- a/extra/http/server/validators/validators.factor
+++ b/extra/http/server/validators/validators.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces
-math.parser assocs new-slots regexp fry unicode.categories
+math.parser assocs regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index e133416101..9c7d64934e 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -3,7 +3,7 @@
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math io.encodings io.streams.duplex
-io.nonblocking new-slots accessors ;
+io.nonblocking accessors ;
IN: io.launcher
diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor
index 163194195d..6c73669e9f 100755
--- a/extra/io/paths/paths.factor
+++ b/extra/io/paths/paths.factor
@@ -1,4 +1,4 @@
-USING: io.files kernel sequences new-slots accessors
+USING: io.files kernel sequences accessors
dlists arrays sequences.lib ;
IN: io.paths
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 7b4831a2c5..a1e42fddf2 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
-io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
+io.unix.launcher.parser io.encodings.latin1 accessors ;
IN: io.unix.launcher
! Search unix first
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 3e49f1dc10..ca8f5f3e59 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
-io.backend new-slots accessors concurrency.flags ;
+io.backend accessors concurrency.flags ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor
index 6fd38e74b2..f2aca0470d 100755
--- a/extra/io/windows/nt/pipes/pipes.factor
+++ b/extra/io/windows/nt/pipes/pipes.factor
@@ -3,7 +3,7 @@
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random
-combinators new-slots accessors ;
+combinators accessors ;
IN: io.windows.nt.pipes
! This code is based on
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index cc1785ff62..640ae0c9ea 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private effects generic
-compiler.units combinators.cleave new-slots accessors ;
+compiler.units combinators.cleave accessors ;
IN: locals
! Inspired by
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
old mode 100644
new mode 100755
index e1ba48281a..2e59b625b1
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -1,6 +1,6 @@
USING: kernel math sequences namespaces
math.miller-rabin combinators.cleave combinators.lib
-math.functions new-slots accessors random ;
+math.functions accessors random ;
IN: random.blum-blum-shub
! TODO: take (log log M) bits instead of 1 bit
diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor
old mode 100644
new mode 100755
index af6e2365bb..12607456ec
--- a/extra/random/dummy/dummy.factor
+++ b/extra/random/dummy/dummy.factor
@@ -1,4 +1,4 @@
-USING: kernel random math new-slots accessors ;
+USING: kernel random math accessors ;
IN: random.dummy
TUPLE: random-dummy i ;
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 73f241a370..bf2ff78f2d 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
-new-slots accessors math.ranges combinators.cleave random ;
+accessors math.ranges combinators.cleave random ;
IN: random.mersenne-twister
<PRIVATE
diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor
old mode 100644
new mode 100755
index be0789ba5e..69c7baba9f
--- a/extra/semantic-db/hierarchy/hierarchy.factor
+++ b/extra/semantic-db/hierarchy/hierarchy.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel new-slots
+USING: accessors db.tuples hashtables kernel
semantic-db semantic-db.relations sequences sequences.deep ;
IN: semantic-db.hierarchy
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
old mode 100644
new mode 100755
index e8075c016d..27e0159596
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
+USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
IN: semantic-db
TUPLE: node id content ;
diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index 36d5e40b77..7bcc336962 100755
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -11,7 +11,7 @@ io.binary strings classes words sbufs tuples arrays vectors
byte-arrays bit-arrays quotations hashtables assocs help.syntax
help.markup float-arrays splitting io.streams.byte-array
io.encodings.string io.encodings.utf8 io.encodings.binary
-combinators combinators.cleave new-slots accessors locals
+combinators combinators.cleave accessors locals
prettyprint compiler.units sequences.private tuples.private ;
IN: serialize
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 58eb42305e..13db422621 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -4,7 +4,7 @@
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar io.encodings.ascii
-calendar.format new-slots accessors ;
+calendar.format accessors ;
IN: smtp
SYMBOL: smtp-domain
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
old mode 100644
new mode 100755
index 32e7433d88..5884c18aee
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -1,6 +1,6 @@
USING: alien alien.c-types kernel windows.ole32
combinators.lib parser splitting sequences.lib
-sequences namespaces new-slots combinators.cleave
+sequences namespaces combinators.cleave
assocs quotations shuffle accessors words macros
alien.syntax fry ;
IN: windows.com.syntax
From 2f93c77e7c20a35d45a37549d0672036f775993c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:35:35 -0500
Subject: [PATCH 148/197] add -lz
---
vm/Config.openbsd | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/vm/Config.openbsd b/vm/Config.openbsd
index 8724ebf378..240adf8087 100644
--- a/vm/Config.openbsd
+++ b/vm/Config.openbsd
@@ -2,4 +2,4 @@ include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o
CC = egcc
CFLAGS += -export-dynamic
-LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)
+LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz
From bf57d5d5aaf496aa88372f4c66ad0df78916a3ac Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:35:59 -0500
Subject: [PATCH 149/197] add openbsd to target
---
misc/target | 3 +++
1 file changed, 3 insertions(+)
diff --git a/misc/target b/misc/target
index 880de8f47a..0be7781301 100755
--- a/misc/target
+++ b/misc/target
@@ -3,6 +3,9 @@
if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
then
echo freebsd-x86-32
+elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ]
+then
+ echo openbsd-x86-32
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
then
echo macosx-ppc
From b42f9605efdd09ff798fb8eed7662714a354e16f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:47:16 -0500
Subject: [PATCH 150/197] fix summary for new ERROR: words
---
core/debugger/debugger.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 00787f9da2..4775093ba7 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -202,13 +202,13 @@ M: no-method error.
M: no-math-method summary
drop "No suitable arithmetic method" ;
-M: check-closed summary
+M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for create-method" ;
-M: check-tuple summary
+M: no-tuple-class summary
drop "Invalid class for define-constructor" ;
M: no-cond summary
@@ -246,7 +246,7 @@ M: no-compilation-unit error.
M: no-vocab summary
drop "Vocabulary does not exist" ;
-M: check-ptr summary
+M: bad-ptr summary
drop "Memory allocation failed" ;
M: double-free summary
From a556cdbed149bcbca958df7542f0ec9ef1bcfe59 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 15:47:24 -0500
Subject: [PATCH 151/197] document ERROR:
---
core/syntax/syntax-docs.factor | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index dc06a239de..ebdd95ae14 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -560,6 +560,13 @@ HELP: TUPLE:
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
+HELP: ERROR:
+{ $syntax "ERROR: class slots... ;" }
+{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
+{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
+
+{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
+
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }
From 5b507693b953781e21911e63bdd66dcbfdc43fab Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 16:01:34 -0500
Subject: [PATCH 152/197] fix tuples unit test
---
core/tuples/tuples-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor
index 63bb233654..b5076ea22b 100755
--- a/core/tuples/tuples-tests.factor
+++ b/core/tuples/tuples-tests.factor
@@ -236,7 +236,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ check-tuple? ] is? ] must-fail-with
+] [ [ no-tuple-class? ] is? ] must-fail-with
! Hardcore unit tests
USE: threads
From 44b1783333273f1902cfc2aafe82c9c6dc560199 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 16:50:02 -0500
Subject: [PATCH 153/197] Remove extra/new-slots; its in the core now
---
extra/new-slots/authors.txt | 1 -
extra/new-slots/new-slots.factor | 67 --------------------------------
2 files changed, 68 deletions(-)
delete mode 100755 extra/new-slots/authors.txt
delete mode 100755 extra/new-slots/new-slots.factor
diff --git a/extra/new-slots/authors.txt b/extra/new-slots/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/new-slots/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor
deleted file mode 100755
index 9773da7b41..0000000000
--- a/extra/new-slots/new-slots.factor
+++ /dev/null
@@ -1,67 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: effects words kernel sequences slots slots.private
-assocs parser mirrors namespaces math vocabs tuples ;
-IN: new-slots
-
-: create-accessor ( name effect -- word )
- >r "accessors" create dup r>
- "declared-effect" set-word-prop ;
-
-: reader-effect T{ effect f { "object" } { "value" } } ; inline
-
-: reader-word ( name -- word )
- ">>" append reader-effect create-accessor ;
-
-: define-reader ( class slot name -- )
- reader-word [ slot ] define-slot-word ;
-
-: writer-effect T{ effect f { "value" "object" } { } } ; inline
-
-: writer-word ( name -- word )
- "(>>" swap ")" 3append writer-effect create-accessor ;
-
-: define-writer ( class slot name -- )
- writer-word [ set-slot ] define-slot-word ;
-
-: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
-
-: setter-word ( name -- word )
- ">>" prepend setter-effect create-accessor ;
-
-: define-setter ( name -- )
- dup setter-word dup deferred? [
- [ \ over , swap writer-word , ] [ ] make define-inline
- ] [ 2drop ] if ;
-
-: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
-
-: changer-word ( name -- word )
- "change-" prepend changer-effect create-accessor ;
-
-: define-changer ( name -- )
- dup changer-word dup deferred? [
- [
- [ over >r >r ] %
- over reader-word ,
- [ r> call r> swap ] %
- swap setter-word ,
- ] [ ] make define-inline
- ] [ 2drop ] if ;
-
-: define-new-slot ( class slot name -- )
- dup define-changer
- dup define-setter
- 3dup define-reader
- define-writer ;
-
-: define-new-slots ( tuple-class -- )
- [ "slot-names" word-prop <enum> >alist ] keep
- [ swap first2 >r 4 + r> define-new-slot ] curry each ;
-
-: TUPLE:
- CREATE-CLASS
- dup ";" parse-tokens define-tuple-class
- define-new-slots ; parsing
-
-"accessors" create-vocab drop
From c1afb4b093636581f7ea74197ee12cb3e87c54e2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 16:52:22 -0500
Subject: [PATCH 154/197] remove stat tests overhaul unique files
---
extra/io/files/unique/backend/backend.factor | 2 +-
extra/io/files/unique/unique-docs.factor | 32 ++++++--------------
extra/io/files/unique/unique.factor | 20 +++++-------
extra/io/unix/files/unique/unique.factor | 5 ++-
extra/io/windows/files/unique/unique.factor | 5 +--
extra/unix/stat/stat-tests.factor | 8 -----
6 files changed, 22 insertions(+), 50 deletions(-)
delete mode 100644 extra/unix/stat/stat-tests.factor
diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor
index b26557688b..7b9809fa28 100644
--- a/extra/io/files/unique/backend/backend.factor
+++ b/extra/io/files/unique/backend/backend.factor
@@ -1,5 +1,5 @@
USING: io.backend ;
IN: io.files.unique.backend
-HOOK: (make-unique-file) io-backend ( path -- stream )
+HOOK: (make-unique-file) io-backend ( path -- )
HOOK: temporary-path io-backend ( -- path )
diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor
index 61f960d9f7..fcfcc15678 100644
--- a/extra/io/files/unique/unique-docs.factor
+++ b/extra/io/files/unique/unique-docs.factor
@@ -6,18 +6,16 @@ ARTICLE: "unique" "Making and using unique files"
"Files:"
{ $subsection make-unique-file }
{ $subsection with-unique-file }
-{ $subsection with-temporary-file }
"Directories:"
{ $subsection make-unique-directory }
-{ $subsection with-unique-directory }
-{ $subsection with-temporary-directory } ;
+{ $subsection with-unique-directory } ;
ABOUT: "unique"
HELP: make-unique-file ( prefix suffix -- path stream )
{ $values { "prefix" "a string" } { "suffix" "a string" }
-{ "path" "a pathname string" } { "stream" "an output stream" } }
-{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link <writer> } " stream." }
+{ "path" "a pathname string" } }
+{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-file } ;
@@ -27,24 +25,12 @@ HELP: make-unique-directory ( -- path )
{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-directory } ;
-HELP: with-unique-file ( quot -- path )
-{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
-{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." }
-{ $notes "The unique file will remain after calling this word." }
-{ $see-also with-temporary-file } ;
-
-HELP: with-unique-directory ( quot -- path )
-{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
-{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." }
-{ $notes "The directory will remain after calling this word." }
-{ $see-also with-temporary-directory } ;
-
-HELP: with-temporary-file ( quot -- )
+HELP: with-unique-file ( prefix suffix quot -- )
{ $values { "quot" "a quotation" } }
-{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." }
-{ $see-also with-unique-file } ;
+{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
+{ $notes "The unique file will be deleted after calling this word." } ;
-HELP: with-temporary-directory ( quot -- )
+HELP: with-unique-directory ( quot -- )
{ $values { "quot" "a quotation" } }
-{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." }
-{ $see-also with-unique-directory } ;
+{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." }
+{ $notes "The directory will be deleted after calling this word." } ;
diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor
index 9a271e402c..a180a28f23 100644
--- a/extra/io/files/unique/unique.factor
+++ b/extra/io/files/unique/unique.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitfields combinators.lib math.parser
random sequences sequences.lib continuations namespaces
-io.files io.backend io.nonblocking io arrays
-io.files.unique.backend system combinators vocabs.loader ;
+io.files io arrays io.files.unique.backend system
+combinators vocabs.loader ;
IN: io.files.unique
<PRIVATE
@@ -21,18 +21,15 @@ IN: io.files.unique
: unique-retries ( -- n ) 10 ; inline
PRIVATE>
-: make-unique-file ( prefix suffix -- path stream )
+: make-unique-file ( prefix suffix -- path )
temporary-path -rot
[
unique-length random-name swap 3append append-path
dup (make-unique-file)
] 3curry unique-retries retry ;
-: with-unique-file ( quot -- path )
- >r f f make-unique-file r> rot [ with-stream ] dip ; inline
-
-: with-temporary-file ( quot -- )
- with-unique-file delete-file ; inline
+: with-unique-file ( prefix suffix quot -- )
+ >r make-unique-file r> keep delete-file ; inline
: make-unique-directory ( -- path )
[
@@ -40,12 +37,9 @@ PRIVATE>
dup make-directory
] unique-retries retry ;
-: with-unique-directory ( quot -- path )
+: with-unique-directory ( quot -- )
>r make-unique-directory r>
- [ with-directory ] curry keep ; inline
-
-: with-temporary-directory ( quot -- )
- with-unique-directory delete-tree ; inline
+ [ with-directory ] curry keep delete-tree ; inline
{
{ [ unix? ] [ "io.unix.files.unique" ] }
diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor
index 185d9cd405..c5365d8d5c 100644
--- a/extra/io/unix/files/unique/unique.factor
+++ b/extra/io/unix/files/unique/unique.factor
@@ -5,8 +5,7 @@ IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
-M: unix-io (make-unique-file) ( path -- duplex-stream )
- open-unique-flags file-mode open dup io-error
- <writer> ;
+M: unix-io (make-unique-file) ( path -- )
+ open-unique-flags file-mode open dup io-error close ;
M: unix-io temporary-path ( -- path ) "/tmp" ;
diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor
index 0823c3f0f3..112dea48a7 100644
--- a/extra/io/windows/files/unique/unique.factor
+++ b/extra/io/windows/files/unique/unique.factor
@@ -2,8 +2,9 @@ USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking ;
IN: io.windows.files.unique
-M: windows-io (make-unique-file) ( path -- stream )
- GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ;
+M: windows-io (make-unique-file) ( path -- )
+ GENERIC_WRITE CREATE_NEW 0 open-file
+ CloseHandle win32-error=0/f ;
M: windows-io temporary-path ( -- path )
"TEMP" os-env ;
diff --git a/extra/unix/stat/stat-tests.factor b/extra/unix/stat/stat-tests.factor
deleted file mode 100644
index 02ae29ae5a..0000000000
--- a/extra/unix/stat/stat-tests.factor
+++ /dev/null
@@ -1,8 +0,0 @@
-USING: kernel tools.test files.unique ;
-IN: unix.stat.tests
-
-[ 123 ] [
- 123 CHAR: a <repetition> [
- write
- ] with-unique-file file-size>>
-] unit-test
From a6e1d83740cae9cf855d3c5dfca4ce01e07889ac Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 17:20:03 -0500
Subject: [PATCH 155/197] add calloc to core/bootstrap/compiler
---
core/bootstrap/compiler/compiler.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 5ccde88e28..04d57dff16 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -79,7 +79,7 @@ nl
"." write flush
{
- malloc free memcpy
+ malloc calloc free memcpy
} compile
" done" print flush
From ca32657972bc2e77b63d18d21a5bf4fad1b5e83f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 17:25:50 -0500
Subject: [PATCH 156/197] Documentation updates
---
core/mirrors/mirrors-docs.factor | 9 ++-
core/slots/slots-docs.factor | 75 ++++++++++++++++++++--
core/syntax/syntax-docs.factor | 2 +-
core/tuples/tuples-docs.factor | 107 ++++++++++++++++++++++++-------
4 files changed, 160 insertions(+), 33 deletions(-)
diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor
index 140f92567b..29ed153a2e 100755
--- a/core/mirrors/mirrors-docs.factor
+++ b/core/mirrors/mirrors-docs.factor
@@ -2,14 +2,17 @@ USING: help.markup help.syntax slots kernel assocs sequences ;
IN: mirrors
ARTICLE: "mirrors" "Mirrors"
-"A reflective view of an object's slots and their values:"
+"The " { $vocab-link "mirrors" } " vocabulary defines data types which present an object's slots and slot values as an associative structure. This enables idioms such as iteration over all slots in a tuple, or editing of tuples, sequences and assocs in a generic fashion. This functionality is used by developer tools and meta-programming utilities."
+$nl
+"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
-"A view of a sequence as an associative structure:"
+"An enum provides such a view of a sequence:"
{ $subsection enum }
{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
-{ $subsection make-mirror } ;
+{ $subsection make-mirror }
+{ $see-also "slots" } ;
ABOUT: "mirrors"
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index 8a1fb16fa9..55cff63963 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -4,21 +4,86 @@ effects generic.standard tuples slots.private classes
strings math ;
IN: slots
+ARTICLE: "accessors" "Slot accessors"
+"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
+{ $list
+ { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
+ { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
+}
+"In addition, two utility words are defined for each distinct slot name used in the system:"
+{ $list
+ { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
+ { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
+}
+"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
+$nl
+"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
+{ $code
+ "<email>"
+ " \"Happy birthday\" >>subject"
+ " { \"bob@bigcorp.com\" } >>to"
+ " \"alice@bigcorp.com\" >>from"
+ "send-email"
+}
+"The following uses writers, and requires some stack shuffling:"
+{ $code
+ "<email>"
+ " \"Happy birthday\" over (>>subject)"
+ " { \"bob@bigcorp.com\" } over (>>to)"
+ " \"alice@bigcorp.com\" over (>>from)"
+ "send-email"
+}
+"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:"
+{ $code
+ "<email>"
+ " swap >>subject"
+ " swap >>to"
+ " \"alice@bigcorp.com\" >>from"
+ "send-email"
+}
+"This is because " { $link swap } " is easier to understand than " { $link tuck } ":"
+{ $code
+ "<email>"
+ " tuck (>>subject)"
+ " tuck (>>to)"
+ " \"alice@bigcorp.com\" over (>>from)"
+ "send-email"
+}
+"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:"
+{ $code
+ "find-manager"
+ " salary>> 0.75 * >>salary"
+}
+"The following version is preferred:"
+{ $code
+ "find-manager"
+ " [ 0.75 * ] change-salary"
+}
+{ $see-also "slots" "mirrors" } ;
+
ARTICLE: "slots" "Slots"
-"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
+"A " { $emphasis "slot" } " is a component of an object which can store a value."
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
+"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
$nl
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
-"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
+"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:"
{ $subsection reader-word }
{ $subsection writer-word }
{ $subsection setter-word }
{ $subsection changer-word }
-"Slot methods type check, then call unsafe primitives:"
-{ $subsection slot }
-{ $subsection set-slot } ;
+"Looking up a slot by name:"
+{ $subsection slot-named }
+"Defining slots dynamically:"
+{ $subsection define-reader }
+{ $subsection define-writer }
+{ $subsection define-setter }
+{ $subsection define-changer }
+{ $subsection define-slot-methods }
+{ $subsection define-accessors }
+{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index dc06a239de..ffb0d883eb 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -556,7 +556,7 @@ HELP: PREDICATE:
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "."
+{ $description "Defines a new tuple class."
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor
index 3af7d27d86..09d93884ad 100755
--- a/core/tuples/tuples-docs.factor
+++ b/core/tuples/tuples-docs.factor
@@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: tuples
-ARTICLE: "tuple-constructors" "Constructors and slots"
-"Tuples are created by calling one of a number of words:"
+ARTICLE: "tuple-constructors" "Constructors"
+"Tuples are created by calling one of two words:"
{ $subsection construct-empty }
{ $subsection construct-boa }
-{ $subsection construct }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl
"A shortcut for defining BOA constructors:"
@@ -19,18 +18,13 @@ $nl
"C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above"
""
- ": <rgb>"
- " { set-color-red set-color-green set-color-blue }"
- " color construct ;"
- ": <rgb> f <rgba> ; ! identical to above"
+ ": <rgb> f <rgba> ;"
""
": <color> construct-empty ;"
- ": <color> { } color construct ; ! identical to above"
": <color> f f f f <rgba> ; ! identical to above"
-}
-"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
+} ;
-ARTICLE: "tuple-delegation" "Delegation"
+ARTICLE: "tuple-delegation" "Tuple delegation"
"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
{ $subsection delegate }
{ $subsection set-delegate }
@@ -48,7 +42,7 @@ $nl
"{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
"{ 1 0 0 } <colored> \"my-shape\" set"
"\"my-ellipse\" get \"my-shape\" get set-delegate"
- "\"my-shape\" get dup colored-color swap ellipse-center .s"
+ "\"my-shape\" get dup color>> swap center>> .s"
"{ 0 0 }\n{ 1 0 0 }"
} ;
@@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
{ $subsection tuple>array }
{ $subsection tuple-slots }
"Tuple classes can also be defined at run time:"
-{ $subsection define-tuple-class } ;
+{ $subsection define-tuple-class }
+{ $see-also "slots" "mirrors" } ;
+
+ARTICLE: "tuple-examples" "Tuple examples"
+"An example:"
+{ $code "TUPLE: employee name salary position ;" }
+"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
+{ $table
+ { "Reader" "Writer" "Setter" "Changer" }
+ { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
+ { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
+ { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
+}
+"We can define a constructor which makes an empty employee:"
+{ $code ": <employee> ( -- employee )"
+ " employee construct-empty ;" }
+"Or we may wish the default constructor to always give employees a starting salary:"
+{ $code
+ ": <employee> ( -- employee )"
+ " employee construct-empty"
+ " 40000 >>salary ;"
+}
+"We can define more refined constructors:"
+{ $code
+ ": <manager> ( -- manager )"
+ " <employee> \"project manager\" >>position ;" }
+"An alternative strategy is to define the most general BOA constructor first:"
+{ $code
+ ": <employee> ( name position -- person )"
+ " 40000 employee construct-boa ;"
+}
+"Now we can define more specific constructors:"
+{ $code
+ ": <manager> ( name -- person )"
+ " \"manager\" <person> ;" }
+"An example using reader words:"
+{ $code
+ "TUPLE: check to amount number ;"
+ ""
+ "SYMBOL: checks"
+ ""
+ ": <check> ( to amount -- check )"
+ " checks counter check construct-boa ;"
+ ""
+ ": biweekly-paycheck ( employee -- check )"
+ " dup name>> swap salary>> 26 / <check> ;"
+}
+"An example of using a changer:"
+{ $code
+ ": positions"
+ " {"
+ " \"junior programmer\""
+ " \"senior programmer\""
+ " \"project manager\""
+ " \"department manager\""
+ " \"executive\""
+ " \"CTO\""
+ " \"CEO\""
+ " \"enterprise Java world dictator\""
+ " } ;"
+ ""
+ ": next-position ( role -- newrole )"
+ " positions [ index 1+ ] keep nth ;"
+ ""
+ ": promote ( person -- person )"
+ " [ 1.2 * ] change-salary"
+ " [ next-position ] change-position ;"
+} ;
ARTICLE: "tuples" "Tuples"
-"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
+"Tuples are user-defined classes composed of named slots."
+{ $subsection "tuple-examples" }
+"A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
-"An example:"
-{ $code "TUPLE: person name address phone ;" "C: <person> person" }
-"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
-{ $table
- { "Reader" "Writer" }
- { { $snippet "person-name" } { $snippet "set-person-name" } }
- { { $snippet "person-address" } { $snippet "set-person-address" } }
- { { $snippet "person-phone" } { $snippet "set-person-phone" } }
-}
+"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
+$nl
+"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
+{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
"Further topics:"
{ $subsection "tuple-delegation" }
-{ $subsection "tuple-introspection" } ;
+{ $subsection "tuple-introspection" }
+"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"
From 0565bbe0bcd6a0d43588b8a15cbc3e2f73a59e72 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 17:25:54 -0500
Subject: [PATCH 157/197] Fix bug
---
extra/tools/vocabs/vocabs.factor | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 44a64cc9dd..b086b30a5e 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -34,8 +34,13 @@ IN: tools.vocabs
: source-modified? ( path -- ? )
dup source-files get at [
- dup source-file-path ?resource-path utf8 file-lines lines-crc32
- swap source-file-checksum = not
+ dup source-file-path ?resource-path
+ dup exists? [
+ utf8 file-lines lines-crc32
+ swap source-file-checksum = not
+ ] [
+ 2drop f
+ ] if
] [
resource-exists?
] ?if ;
From 6d434090e0c3fe7fd778e628442f8c0021093400 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 17:38:39 -0500
Subject: [PATCH 158/197] Fixes
---
core/io/io-tests.factor | 18 +++++++++---------
extra/help/lint/lint.factor | 2 --
extra/help/markup/markup-tests.factor | 12 ------------
3 files changed, 9 insertions(+), 23 deletions(-)
diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor
index 22c942d2d9..8a9089a564 100755
--- a/core/io/io-tests.factor
+++ b/core/io/io-tests.factor
@@ -28,15 +28,6 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
-[ "" ] [ 0 read ] unit-test
-
-! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
-
-[
- "/core/io/test/binary.txt" <resource-reader>
- [ 0.2 read ] with-stream
-] must-fail
-
[
{
{ "It seems " CHAR: J }
@@ -58,3 +49,12 @@ IN: io.tests
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
+
+! [ "" ] [ 0 read ] unit-test
+
+! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
+
+! [
+! "/core/io/test/binary.txt" <resource-reader>
+! [ 0.2 read ] with-stream
+! ] must-fail
diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor
index d8a4f83169..b65e44fda4 100755
--- a/extra/help/lint/lint.factor
+++ b/extra/help/lint/lint.factor
@@ -39,8 +39,6 @@ IN: help.lint
{
$shuffle
$values-x/y
- $slot-reader
- $slot-writer
$predicate
$class-description
$error-description
diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor
index 0b4b69bf59..6b138a18ab 100644
--- a/extra/help/markup/markup-tests.factor
+++ b/extra/help/markup/markup-tests.factor
@@ -4,18 +4,6 @@ IN: help.markup.tests
TUPLE: blahblah quux ;
-: test-slot blahblah "slots" word-prop second ;
-
-[
- { { "blahblah" { $instance blahblah } } { "quux" { $instance object } } }
-] [
- test-slot blahblah ($spec-reader-values)
-] unit-test
-
-[ ] [
- test-slot blahblah $spec-reader-values
-] unit-test
-
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ blahblah-quux help ] unit-test
From 010856c8707998ff187ba5db700552d01d7d00c7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 20 Mar 2008 17:33:01 -0600
Subject: [PATCH 159/197] Add help for math.ranges
---
extra/math/ranges/ranges-docs.factor | 21 +++++++++++++++++++++
extra/math/ranges/ranges.factor | 16 ++++++++--------
2 files changed, 29 insertions(+), 8 deletions(-)
create mode 100644 extra/math/ranges/ranges-docs.factor
diff --git a/extra/math/ranges/ranges-docs.factor b/extra/math/ranges/ranges-docs.factor
new file mode 100644
index 0000000000..a8783ee410
--- /dev/null
+++ b/extra/math/ranges/ranges-docs.factor
@@ -0,0 +1,21 @@
+USING: help.syntax help.markup ;
+
+IN: math.ranges
+
+ARTICLE: "ranges" "Ranges"
+
+ "A " { $emphasis "range" } " is a virtual sequence with elements "
+ "ranging from a to b by step."
+
+ $nl
+
+ "Creating ranges:"
+
+ { $subsection <range> }
+ { $subsection [a,b] }
+ { $subsection (a,b] }
+ { $subsection [a,b) }
+ { $subsection (a,b) }
+ { $subsection [0,b] }
+ { $subsection [1,b] }
+ { $subsection [0,b) } ;
\ No newline at end of file
diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor
index ade3b63a5c..9215fc3acd 100755
--- a/extra/math/ranges/ranges.factor
+++ b/extra/math/ranges/ranges.factor
@@ -3,7 +3,7 @@ IN: math.ranges
TUPLE: range from length step ;
-: <range> ( from to step -- range )
+: <range> ( a b step -- range )
>r over - r>
[ / 1+ 0 max >integer ] keep
range construct-boa ;
@@ -22,19 +22,19 @@ INSTANCE: range immutable-sequence
: ,b) dup neg rot + swap ; inline
-: [a,b] twiddle <range> ;
+: [a,b] ( a b -- range ) twiddle <range> ;
-: (a,b] twiddle (a, <range> ;
+: (a,b] ( a b -- range ) twiddle (a, <range> ;
-: [a,b) twiddle ,b) <range> ;
+: [a,b) ( a b -- range ) twiddle ,b) <range> ;
-: (a,b) twiddle (a, ,b) <range> ;
+: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ;
-: [0,b] 0 swap [a,b] ;
+: [0,b] ( b -- range ) 0 swap [a,b] ;
-: [1,b] 1 swap [a,b] ;
+: [1,b] ( b -- range ) 1 swap [a,b] ;
-: [0,b) 0 swap [a,b) ;
+: [0,b) ( b -- range ) 0 swap [a,b) ;
: range-increasing? ( range -- ? )
range-step 0 > ;
From fe68d41a11b05be531397acb23edf1c78245435b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 17:46:47 -0500
Subject: [PATCH 160/197] Fix windows time
---
extra/windows/time/time.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
mode change 100644 => 100755 extra/windows/time/time.factor
diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor
old mode 100644
new mode 100755
index e910ca2888..63b12de1ff
--- a/extra/windows/time/time.factor
+++ b/extra/windows/time/time.factor
@@ -8,7 +8,7 @@ IN: windows.time
32 shift bitor ;
: windows-1601 ( -- timestamp )
- 1601 1 1 0 0 0 0 <timestamp> ;
+ 1601 1 1 0 0 0 instant <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep
From 3664f7af1bcb4a6d9bb30d1d9aff06f59b001914 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 17:58:35 -0500
Subject: [PATCH 161/197] Fix loader regression
---
core/parser/parser-tests.factor | 10 +++++++++-
core/vocabs/loader/loader.factor | 6 +++++-
core/vocabs/vocabs.factor | 3 +--
3 files changed, 15 insertions(+), 4 deletions(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index e46f179424..f024eda54c 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -1,7 +1,7 @@
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units debugger vocabs.loader ;
+sorting tuples compiler.units debugger vocabs vocabs.loader ;
IN: parser.tests
[
@@ -461,3 +461,11 @@ must-fail-with
] times
[ ] [ "parser" reload ] unit-test
+
+[ ] [
+ [ "this-better-not-exist" forget-vocab ] with-compilation-unit
+] unit-test
+
+[
+ "USE: this-better-not-exist" eval
+] must-fail
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 103b5290a4..9478c1f4f7 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -113,7 +113,11 @@ M: string (load-vocab)
rethrow
] [
drop
- [ (load-vocab) ] with-compiler-errors
+ dup find-vocab-root [
+ [ (load-vocab) ] with-compiler-errors
+ ] [
+ dup vocab [ drop ] [ no-vocab ] if
+ ] if
] if
] with-compiler-errors
] load-vocab-hook set-global
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 38df17c0b5..f111b5bc74 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -64,8 +64,7 @@ ERROR: no-vocab name ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
- dup load-vocab-hook get call
- dup vocab [ ] [ vocab-name no-vocab ] ?if ;
+ dup load-vocab-hook get call vocab ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
From 3131e96aa72e146b49a00a5970fa46b128e4276e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 19:54:25 -0500
Subject: [PATCH 162/197] Fixes
---
core/parser/parser-docs.factor | 2 +-
core/parser/parser.factor | 8 ++++----
extra/http/server/templating/fhtml/fhtml.factor | 2 +-
extra/regexp/regexp.factor | 2 +-
4 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 48f929b836..4d200c17d2 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -224,7 +224,7 @@ HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
-HELP: change-column
+HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 887747d7d8..28822db708 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -60,7 +60,7 @@ t parser-notes set-global
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ;
-: change-column ( lexer quot -- )
+: change-lexer-column ( lexer quot -- )
swap
[ dup lexer-column swap lexer-line-text rot call ] keep
set-lexer-column ; inline
@@ -68,14 +68,14 @@ t parser-notes set-global
GENERIC: skip-blank ( lexer -- )
M: lexer skip-blank ( lexer -- )
- [ t skip ] change-column ;
+ [ t skip ] change-lexer-column ;
GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
- ] change-column ;
+ ] change-lexer-column ;
: still-parsing? ( lexer -- ? )
dup lexer-line swap lexer-text length <= ;
@@ -153,7 +153,7 @@ name>char-hook global [
: parse-string ( -- str )
lexer get [
[ swap tail-slice (parse-string) ] "" make swap
- ] change-column ;
+ ] change-lexer-column ;
TUPLE: parse-error file line col text ;
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 8567524217..630054ccfa 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -28,7 +28,7 @@ M: template-lexer skip-word
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
{ [ t ] [ f skip ] }
} cond
- ] change-column ;
+ ] change-lexer-column ;
DEFER: <% delimiter
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 8a642a8692..b57724d1db 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -292,7 +292,7 @@ TUPLE: regexp source parser ignore-case? ;
: parse-regexp ( accum end -- accum )
lexer get dup skip-blank [
[ index* dup 1+ swap ] 2keep swapd subseq swap
- ] change-column
+ ] change-lexer-column
lexer get (parse-token) parse-options <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing
From 69763af858e9b48c0df2843fb04305e000060a03 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 20 Mar 2008 19:08:32 -0600
Subject: [PATCH 163/197] builder.util: new-slots are in core
---
extra/builder/util/util.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
index 82514ca43d..55ff38d408 100644
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
combinators sequences splitting quotations arrays strings tools.time
- sequences.deep new-slots accessors assocs.lib
+ sequences.deep accessors assocs.lib
io.encodings.utf8
combinators.cleave bake calendar calendar.format ;
From dffb45908c9e81348f758065564353e0a81c4db1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 20 Mar 2008 19:56:30 -0500
Subject: [PATCH 164/197] Fixing help failures
---
core/generic/generic-docs.factor | 4 ++--
core/generic/math/math-docs.factor | 2 +-
2 files changed, 3 insertions(+), 3 deletions(-)
mode change 100644 => 100755 core/generic/math/math-docs.factor
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 62b85dde3a..b59c92c798 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -126,7 +126,7 @@ HELP: method
{ method create-method POSTPONE: M: } related-words
HELP: <method>
-{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
+{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
HELP: methods
@@ -143,7 +143,7 @@ HELP: check-method
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
-{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
+{ $values { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor
old mode 100644
new mode 100755
index cbbf070398..5c15e43eb5
--- a/core/generic/math/math-docs.factor
+++ b/core/generic/math/math-docs.factor
@@ -15,7 +15,7 @@ HELP: no-math-method
HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
+{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
From 4b32fa4d0544c235d7d63ca2d795012631184386 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:11:45 -0500
Subject: [PATCH 165/197] Fixing help-lint typos
---
core/alien/syntax/syntax.factor | 4 ++--
core/io/encodings/encodings-docs.factor | 12 ++++++------
core/io/encodings/encodings.factor | 2 +-
core/slots/slots-docs.factor | 10 +++++-----
core/slots/slots.factor | 2 +-
5 files changed, 15 insertions(+), 15 deletions(-)
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index 3bd68bfde7..6e4b8b4e21 100755
--- a/core/alien/syntax/syntax.factor
+++ b/core/alien/syntax/syntax.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations
@@ -9,7 +9,7 @@ IN: alien.syntax
<PRIVATE
: parse-arglist ( return seq -- types effect )
- 2 group dup keys swap values
+ 2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: function-quot ( type lib func types -- quot )
diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor
index 548d2cd7fc..fd5ddaa82d 100644
--- a/core/io/encodings/encodings-docs.factor
+++ b/core/io/encodings/encodings-docs.factor
@@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream"
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
-HELP: <encoder> ( stream encoding -- newstream )
+HELP: <encoder>
{ $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
-HELP: <decoder> ( stream encoding -- newstream )
+HELP: <decoder>
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
-HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
+HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
@@ -50,12 +50,12 @@ ARTICLE: "encodings-protocol" "Encoding protocol"
{ $subsection <encoder> }
{ $subsection <decoder> } ;
-HELP: decode-char ( stream encoding -- char/f )
+HELP: decode-char
{ $values { "stream" "an underlying input stream" }
- { "encoding" "An encoding descriptor tuple" } }
+ { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
-HELP: encode-char ( char stream encoding -- )
+HELP: encode-char
{ $values { "char" "a character" }
{ "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 610d294bb6..a781b63ad5 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -12,7 +12,7 @@ GENERIC: decode-char ( stream encoding -- char/f )
GENERIC: encode-char ( char stream encoding -- )
-GENERIC: <decoder> ( stream decoding -- newstream )
+GENERIC: <decoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ;
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index 55cff63963..e4bb307829 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -123,8 +123,8 @@ HELP: reader-effect
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
-{ $values { "class" class } { "spec" slot-spec } }
-{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." }
+{ $values { "class" class } { "name" string } { "slot" integer } }
+{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: writer-effect
@@ -132,13 +132,13 @@ HELP: writer-effect
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
HELP: define-writer
-{ $values { "class" class } { "spec" slot-spec } }
+{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slot-methods
-{ $values { "class" class } { "spec" slot-spec } }
-{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
+{ $values { "class" class } { "name" string } { "slot" integer } }
+{ $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-accessors
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 025cf97420..ed5de3a439 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -23,7 +23,7 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
-: slot-named ( string specs -- spec/f )
+: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )
From 78bd877339d05fe03e92c0c8e2ce3ef1dd48e1e6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:12:01 -0500
Subject: [PATCH 166/197] Fix groups set-length
---
core/splitting/splitting-tests.factor | 8 +++++++-
core/splitting/splitting.factor | 2 +-
2 files changed, 8 insertions(+), 2 deletions(-)
diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor
index d60403362c..34757e6b22 100644
--- a/core/splitting/splitting-tests.factor
+++ b/core/splitting/splitting-tests.factor
@@ -1,4 +1,4 @@
-USING: splitting tools.test ;
+USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail
@@ -56,3 +56,9 @@ unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+ V{ "a" "b" } clone 2 <groups>
+ 2 over set-length
+ >array
+] unit-test
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index 6416e27eaf..419a30dda4 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -17,7 +17,7 @@ M: groups length
dup groups-seq length swap groups-n [ + 1- ] keep /i ;
M: groups set-length
- [ groups-n * ] keep delegate set-length ;
+ [ groups-n * ] keep groups-seq set-length ;
: group@ ( n groups -- from to seq )
[ groups-n [ * dup ] keep + ] keep
From 3164c857c7e778c0fd6d7c666e158adb0901a19d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:13:13 -0500
Subject: [PATCH 167/197] Generic slots for the win
---
core/alien/alien.factor | 2 +-
core/alien/compiler/compiler.factor | 54 ++++++++++-------------------
core/cpu/x86/32/32.factor | 6 ++--
3 files changed, 23 insertions(+), 39 deletions(-)
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 0afff0c497..436d73e874 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -77,7 +77,7 @@ ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ;
-TUPLE: alien-invoke library function return parameters ;
+TUPLE: alien-invoke library function return parameters abi ;
ERROR: alien-invoke-error library symbol ;
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index fb7d50e882..3e0062c85a 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -6,14 +6,9 @@ inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
-compiler.errors continuations layouts ;
+compiler.errors continuations layouts accessors ;
IN: alien.compiler
-! Common protocol for alien-invoke/alien-callback/alien-indirect
-GENERIC: alien-node-parameters ( node -- seq )
-GENERIC: alien-node-return ( node -- ctype )
-GENERIC: alien-node-abi ( node -- str )
-
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
@@ -22,11 +17,11 @@ GENERIC: alien-node-abi ( node -- str )
] if ;
: alien-node-parameters* ( node -- seq )
- dup alien-node-parameters
- swap alien-node-return large-struct? [ "void*" add* ] when ;
+ dup parameters>>
+ swap return>> large-struct? [ "void*" add* ] when ;
: alien-node-return* ( node -- ctype )
- alien-node-return dup large-struct? [ drop "void" ] when ;
+ return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
@@ -51,7 +46,7 @@ GENERIC: alien-node-abi ( node -- str )
: alien-invoke-frame ( node -- n )
#! One cell is temporary storage, temp@
- dup alien-node-return return-size
+ dup return>> return-size
swap alien-stack-frame +
cell + ;
@@ -147,9 +142,9 @@ M: long-long-type flatten-value-type ( type -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: alien-invoke-stack ( node extra -- )
- over alien-node-parameters length + dup reify-curries
+ over parameters>> length + dup reify-curries
over consume-values
- dup alien-node-return "void" = 0 1 ?
+ dup return>> "void" = 0 1 ?
swap produce-values ;
: (make-prep-quot) ( parameters -- )
@@ -161,11 +156,11 @@ M: long-long-type flatten-value-type ( type -- )
] if ;
: make-prep-quot ( node -- quot )
- alien-node-parameters
+ parameters>>
[ <reversed> (make-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
- alien-node-parameters [
+ parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
@@ -174,7 +169,7 @@ M: long-long-type flatten-value-type ( type -- )
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- alien-node-return dup large-struct?
+ return>> dup large-struct?
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
: objects>registers ( node -- )
@@ -188,14 +183,7 @@ M: long-long-type flatten-value-type ( type -- )
] with-param-regs ;
: box-return* ( node -- )
- alien-node-return [ ] [ box-return ] if-void ;
-
-M: alien-invoke alien-node-parameters alien-invoke-parameters ;
-M: alien-invoke alien-node-return alien-invoke-return ;
-
-M: alien-invoke alien-node-abi
- alien-invoke-library library
- [ library-abi ] [ "cdecl" ] if* ;
+ return>> [ ] [ box-return ] if-void ;
M: alien-invoke-error summary
drop
@@ -205,7 +193,7 @@ M: alien-invoke-error summary
: stdcall-mangle ( symbol node -- symbol )
"@"
- swap alien-node-parameters parameter-sizes drop
+ swap parameters>> parameter-sizes drop
number>string 3append ;
TUPLE: no-such-library name ;
@@ -256,6 +244,10 @@ M: no-such-symbol compiler-error-type
pop-literal nip over set-alien-invoke-return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
+ ! Set ABI
+ dup alien-invoke-library
+ library [ library-abi ] [ "cdecl" ] if*
+ over set-alien-invoke-abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
@@ -274,10 +266,6 @@ M: alien-invoke generate-node
iterate-next
] with-stack-frame ;
-M: alien-indirect alien-node-parameters alien-indirect-parameters ;
-M: alien-indirect alien-node-return alien-indirect-return ;
-M: alien-indirect alien-node-abi alien-indirect-abi ;
-
M: alien-indirect-error summary
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
@@ -323,10 +311,6 @@ callbacks global [ H{ } assoc-like ] change-at
: register-callback ( word -- ) dup callbacks get set-at ;
-M: alien-callback alien-node-parameters alien-callback-parameters ;
-M: alien-callback alien-node-return alien-callback-return ;
-M: alien-callback alien-node-abi alien-callback-abi ;
-
M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
@@ -373,7 +357,7 @@ TUPLE: callback-context ;
wait-to-return ; inline
: prepare-callback-return ( ctype -- quot )
- alien-node-return {
+ return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
{ [ t ] [ c-type c-type-prep ] }
@@ -390,8 +374,8 @@ TUPLE: callback-context ;
: callback-unwind ( node -- n )
{
- { [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] }
- { [ dup alien-node-return large-struct? ] [ drop 4 ] }
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
{ [ t ] [ drop 0 ] }
} cond ;
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 19b913541c..81a7d7cd02 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line
-compiler compiler.units io vocabs.loader ;
+compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
@@ -244,10 +244,10 @@ M: x86-32-backend %cleanup ( alien-node -- )
#! have to fix ESP.
{
{
- [ dup alien-node-abi "stdcall" = ]
+ [ dup abi>> "stdcall" = ]
[ alien-stack-frame ESP swap SUB ]
} {
- [ dup alien-node-return large-struct? ]
+ [ dup return>> large-struct? ]
[ drop EAX PUSH ]
} {
[ t ] [ drop ]
From f98dbbbe7471110e2ce29b7132c3359f0f8ca6fc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:14:07 -0500
Subject: [PATCH 168/197] Clean up dlists
---
core/dlists/dlists-docs.factor | 10 +-
core/dlists/dlists-tests.factor | 26 ++--
core/dlists/dlists.factor | 126 +++++++++---------
.../mailboxes/mailboxes-docs.factor | 4 +-
.../mailboxes/mailboxes-tests.factor | 14 +-
extra/concurrency/mailboxes/mailboxes.factor | 18 +--
extra/concurrency/messaging/messaging.factor | 6 +-
7 files changed, 102 insertions(+), 102 deletions(-)
diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor
index 2aeaadad3e..c957c04453 100755
--- a/core/dlists/dlists-docs.factor
+++ b/core/dlists/dlists-docs.factor
@@ -85,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl
@@ -93,20 +93,20 @@ HELP: dlist-find
} ;
HELP: dlist-contains?
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if*
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } }
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ;
HELP: dlist-each
-{ $values { "quot" quotation } { "dlist" { $link dlist } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
index cd651bff2f..2bc0e6a3fb 100755
--- a/core/dlists/dlists-tests.factor
+++ b/core/dlists/dlists-tests.factor
@@ -43,20 +43,20 @@ IN: dlists.tests
dlist-front dlist-node-next dlist-node-next
] unit-test
-[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
-[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
-[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
-[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
+[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
+[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
+[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
-[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
+[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index 38c4ee233e..56134f3b54 100755
--- a/core/dlists/dlists.factor
+++ b/core/dlists/dlists.factor
@@ -1,71 +1,67 @@
-! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
+! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
+! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences ;
+USING: combinators kernel math sequences accessors ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist construct-empty
- 0 over set-dlist-length ;
+ 0 >>length ;
-: dlist-empty? ( dlist -- ? ) dlist-front not ;
+: dlist-empty? ( dlist -- ? ) front>> not ;
<PRIVATE
+
TUPLE: dlist-node obj prev next ;
+
C: <dlist-node> dlist-node
: inc-length ( dlist -- )
- [ dlist-length 1+ ] keep set-dlist-length ; inline
+ [ 1+ ] change-length drop ; inline
: dec-length ( dlist -- )
- [ dlist-length 1- ] keep set-dlist-length ; inline
+ [ 1- ] change-length drop ; inline
: set-prev-when ( dlist-node dlist-node/f -- )
- [ set-dlist-node-prev ] [ drop ] if* ;
+ [ (>>prev) ] [ drop ] if* ;
: set-next-when ( dlist-node dlist-node/f -- )
- [ set-dlist-node-next ] [ drop ] if* ;
+ [ (>>next) ] [ drop ] if* ;
: set-next-prev ( dlist-node -- )
- dup dlist-node-next set-prev-when ;
+ dup next>> set-prev-when ;
: normalize-front ( dlist -- )
- dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
+ dup back>> [ f >>front ] unless drop ;
: normalize-back ( dlist -- )
- dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
+ dup front>> [ f >>back ] unless drop ;
: set-back-to-front ( dlist -- )
- dup dlist-back
- [ drop ] [ dup dlist-front swap set-dlist-back ] if ;
+ dup back>> [ dup front>> >>back ] unless drop ;
: set-front-to-back ( dlist -- )
- dup dlist-front
- [ drop ] [ dup dlist-back swap set-dlist-front ] if ;
+ dup front>> [ dup back>> >>front ] unless drop ;
-: (dlist-find-node) ( quot dlist-node -- node/f ? )
- dup dlist-node-obj pick dupd call [
- drop nip t
- ] [
- drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
- ] if ; inline
+: (dlist-find-node) ( dlist-node quot -- node/f ? )
+ over [
+ [ >r obj>> r> call ] 2keep rot
+ [ drop t ] [ >r next>> r> (dlist-find-node) ] if
+ ] [ 2drop f f ] if ; inline
-: dlist-find-node ( quot dlist -- node/f ? )
- dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
+: dlist-find-node ( dlist quot -- node/f ? )
+ >r front>> r> (dlist-find-node) ; inline
-: (dlist-each-node) ( quot dlist -- )
- over
- [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
- [ 2drop ] if ; inline
+: dlist-each-node ( dlist quot -- )
+ [ t ] compose dlist-find-node 2drop ; inline
-: dlist-each-node ( quot dlist -- )
- >r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
: push-front* ( obj dlist -- dlist-node )
- [ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
- [ set-dlist-front ] keep
+ [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
+ [ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
@@ -76,9 +72,9 @@ PRIVATE>
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
- [ dlist-back f <dlist-node> ] keep
- [ dlist-back set-next-when ] 2keep
- [ set-dlist-back ] 2keep
+ [ back>> f <dlist-node> ] keep
+ [ back>> set-next-when ] 2keep
+ [ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
@@ -89,70 +85,75 @@ PRIVATE>
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
- dlist-front dlist-node-obj ;
+ front>> obj>> ;
: pop-front ( dlist -- obj )
- dup dlist-front [
- dup dlist-node-next
- f rot set-dlist-node-next
+ dup front>> [
+ dup next>>
+ f rot (>>next)
f over set-prev-when
- swap set-dlist-front
- ] 2keep dlist-node-obj
+ swap (>>front)
+ ] 2keep obj>>
swap [ normalize-back ] keep dec-length ;
: pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj )
- dlist-back dlist-node-obj ;
+ back>> obj>> ;
: pop-back ( dlist -- obj )
- dup dlist-back [
- dup dlist-node-prev
- f rot set-dlist-node-prev
+ dup back>> [
+ dup prev>>
+ f rot (>>prev)
f over set-next-when
- swap set-dlist-back
- ] 2keep dlist-node-obj
+ swap (>>back)
+ ] 2keep obj>>
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ;
-: dlist-find ( quot dlist -- obj/f ? )
- dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
+: dlist-find ( dlist quot -- obj/f ? )
+ dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-: dlist-contains? ( quot dlist -- ? )
+: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
- dup dlist-node-prev over dlist-node-next set-prev-when
- dup dlist-node-next swap dlist-node-prev set-next-when ;
+ dup prev>> over next>> set-prev-when
+ dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- )
{
- { [ over dlist-front over eq? ] [ drop pop-front* ] }
- { [ over dlist-back over eq? ] [ drop pop-back* ] }
+ { [ over front>> over eq? ] [ drop pop-front* ] }
+ { [ over back>> over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] }
} cond ;
-: delete-node-if* ( quot dlist -- obj/f ? )
- tuck dlist-find-node [
- [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
+: delete-node-if* ( dlist quot -- obj/f ? )
+ dupd dlist-find-node [
+ dup [
+ [ delete-node ] keep obj>> t
+ ] [
+ 2drop f f
+ ] if
] [
2drop f f
] if ; inline
-: delete-node-if ( quot dlist -- obj/f )
+: delete-node-if ( dlist quot -- obj/f )
delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
- >r [ eq? ] curry r> delete-node-if ;
+ swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
- f over set-dlist-front
- f over set-dlist-back
- 0 swap set-dlist-length ;
+ f >>front
+ f >>back
+ 0 >>length
+ drop ;
: dlist-each ( dlist quot -- )
- [ dlist-node-obj ] swap compose dlist-each-node ; inline
+ [ obj>> ] swap compose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?
@@ -160,4 +161,3 @@ PRIVATE>
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-
diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor
index 4937ef1fb9..50694776c5 100755
--- a/extra/concurrency/mailboxes/mailboxes-docs.factor
+++ b/extra/concurrency/mailboxes/mailboxes-docs.factor
@@ -49,8 +49,8 @@ HELP: while-mailbox-empty
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
- { "mailbox" mailbox }
+{ $values { "mailbox" mailbox }
+ { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor
index 24d83b2961..2cb12bcaba 100755
--- a/extra/concurrency/mailboxes/mailboxes-tests.factor
+++ b/extra/concurrency/mailboxes/mailboxes-tests.factor
@@ -16,9 +16,9 @@ tools.test math kernel strings ;
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
@@ -27,10 +27,10 @@ tools.test math kernel strings ;
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ string? ] swap mailbox-get? swap push ] in-thread
- [ [ string? ] swap mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ string? ] mailbox-get? swap push ] in-thread
+ [ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put
diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor
index 28b2fb7221..7b6405679f 100755
--- a/extra/concurrency/mailboxes/mailboxes.factor
+++ b/extra/concurrency/mailboxes/mailboxes.factor
@@ -17,17 +17,17 @@ TUPLE: mailbox threads data ;
[ mailbox-data push-front ] keep
mailbox-threads notify-all yield ;
-: block-unless-pred ( pred mailbox timeout -- )
- 2over mailbox-data dlist-contains? [
+: block-unless-pred ( mailbox timeout pred -- )
+ pick mailbox-data over dlist-contains? [
3drop
] [
- 2dup >r mailbox-threads r> "mailbox" wait
+ >r over mailbox-threads over "mailbox" wait r>
block-unless-pred
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
- 2dup >r mailbox-threads r> "mailbox" wait
+ over mailbox-threads over "mailbox" wait
block-if-empty
] [
drop
@@ -58,12 +58,12 @@ TUPLE: mailbox threads data ;
2drop
] if ; inline
-: mailbox-get-timeout? ( pred mailbox timeout -- obj )
- [ block-unless-pred ] 3keep drop
- mailbox-data delete-node-if ; inline
+: mailbox-get-timeout? ( mailbox timeout pred -- obj )
+ 3dup block-unless-pred
+ nip >r mailbox-data r> delete-node-if ; inline
-: mailbox-get? ( pred mailbox -- obj )
- f mailbox-get-timeout? ; inline
+: mailbox-get? ( mailbox pred -- obj )
+ f swap mailbox-get-timeout? ; inline
TUPLE: linked-error thread ;
diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor
index e566a83fdf..2cd83d43f5 100755
--- a/extra/concurrency/messaging/messaging.factor
+++ b/extra/concurrency/messaging/messaging.factor
@@ -26,10 +26,10 @@ M: thread send ( message thread -- )
my-mailbox swap mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
- my-mailbox mailbox-get? ?linked ; inline
+ my-mailbox swap mailbox-get? ?linked ; inline
-: receive-if-timeout ( pred timeout -- message )
- my-mailbox swap mailbox-get-timeout? ?linked ; inline
+: receive-if-timeout ( timeout pred -- message )
+ my-mailbox -rot mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked-error> r> send ;
From 59731ee24a7882e0e58917df7297f25ec546b92a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:14:16 -0500
Subject: [PATCH 169/197] Use delete-node instead of dlist-delete
---
extra/ui/gadgets/gadgets.factor | 15 +++++++++------
1 file changed, 9 insertions(+), 6 deletions(-)
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index ed3631bca5..267f6f0f0f 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -46,7 +46,7 @@ M: array rect-dim drop { 0 0 } ;
TUPLE: gadget
pref-dim parent children orientation focus
-visible? root? clipped? layout-state graft-state
+visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
@@ -254,17 +254,20 @@ M: gadget layout* drop ;
: graft-queue \ graft-queue get ;
: unqueue-graft ( gadget -- )
- dup graft-queue dlist-delete [ "Not queued" throw ] unless
+ graft-queue over gadget-graft-node delete-node
dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ;
+: (queue-graft) ( gadget flags -- )
+ over set-gadget-graft-state
+ dup graft-queue push-front* swap set-gadget-graft-node
+ notify-ui-thread ;
+
: queue-graft ( gadget -- )
- { f t } over set-gadget-graft-state
- graft-queue push-front notify-ui-thread ;
+ { f t } (queue-graft) ;
: queue-ungraft ( gadget -- )
- { t f } over set-gadget-graft-state
- graft-queue push-front notify-ui-thread ;
+ { t f } (queue-graft) ;
: graft-later ( gadget -- )
dup gadget-graft-state {
From e621a92caec52b6f208421c23d613b19e0a98f6c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:52:43 -0500
Subject: [PATCH 170/197] -output-image now relative to current directory
---
core/bootstrap/stage2.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 2523841aaf..f472e0158f 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -12,7 +12,7 @@ SYMBOL: bootstrap-time
: default-image-name ( -- string )
vm file-name windows? [ "." split1 drop ] when
- ".image" append ;
+ ".image" append resource-path ;
: do-crossref ( -- )
"Cross-referencing..." print flush
@@ -106,5 +106,5 @@ f error-continuation set-global
millis r> - dup bootstrap-time set-global
print-report
- "output-image" get resource-path save-image-and-exit
+ "output-image" get save-image-and-exit
] if
From 314bef5e7804da3033b6674ee8f49fd3821a7fca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 20:52:58 -0500
Subject: [PATCH 171/197] Add support for -resource-path command line switch
---
core/io/files/files.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index f9116895e4..21cc7c8f0a 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -190,7 +190,7 @@ DEFER: copy-tree-into
! Special paths
: resource-path ( path -- newpath )
- \ resource-path get [ image parent-directory ] unless*
+ "resource-path" get [ image parent-directory ] unless*
prepend-path ;
: ?resource-path ( path -- newpath )
From 0d0f0c5ce7bf2c7bd9d7b73a818a181b590de583 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 21:11:53 -0500
Subject: [PATCH 172/197] Improve deployment tool
---
extra/bunny/deploy.factor | 15 ++++---
extra/hello-ui/deploy.factor | 13 +++---
extra/hello-world/deploy.factor | 11 ++---
extra/sudoku/deploy.factor | 11 ++---
extra/tools/deploy/backend/backend.factor | 46 +++++++++++++-------
extra/tools/deploy/config/config-docs.factor | 17 +++++---
extra/tools/deploy/config/config.factor | 2 +
extra/tools/deploy/restage/restage.factor | 8 ++++
extra/tools/deploy/shaker/shaker.factor | 5 +--
extra/tools/deploy/test/1/deploy.factor | 15 ++++---
extra/tools/deploy/test/2/deploy.factor | 15 ++++---
extra/tools/deploy/test/3/deploy.factor | 15 ++++---
extra/ui/tools/deploy/deploy.factor | 1 +
13 files changed, 106 insertions(+), 68 deletions(-)
create mode 100644 extra/tools/deploy/restage/restage.factor
diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor
index a3f6174726..643737b23c 100755
--- a/extra/bunny/deploy.factor
+++ b/extra/bunny/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "Bunny" }
{ deploy-threads? t }
- { deploy-word-props? f }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
- { deploy-io 3 }
{ deploy-compiler? t }
- { deploy-word-defs? f }
+ { deploy-math? t }
{ deploy-c-types? f }
+ { deploy-io 3 }
+ { deploy-reflection 1 }
+ { deploy-ui? t }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor
index 43d8ca21ef..0ec9c19503 100755
--- a/extra/hello-ui/deploy.factor
+++ b/extra/hello-ui/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-io 1 }
- { deploy-compiler? t }
{ deploy-word-defs? f }
- { deploy-word-props? f }
- { deploy-math? t }
+ { deploy-random? t }
{ deploy-name "Hello world" }
- { deploy-c-types? f }
- { deploy-ui? t }
{ deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-c-types? f }
+ { deploy-io 1 }
{ deploy-reflection 1 }
+ { deploy-ui? t }
{ "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor
index 2341aabc9d..77421938a9 100755
--- a/extra/hello-world/deploy.factor
+++ b/extra/hello-world/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "Hello world (console)" }
{ deploy-threads? f }
- { deploy-c-types? f }
{ deploy-compiler? f }
- { deploy-ui? f }
{ deploy-math? f }
- { deploy-reflection 1 }
- { deploy-word-defs? f }
+ { deploy-c-types? f }
{ deploy-io 2 }
- { deploy-word-props? f }
+ { deploy-reflection 1 }
+ { deploy-ui? f }
{ "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor
index 11a06f46bc..ba1ac1a32a 100755
--- a/extra/sudoku/deploy.factor
+++ b/extra/sudoku/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
- { deploy-c-types? f }
{ deploy-compiler? t }
- { deploy-ui? f }
{ deploy-math? f }
- { deploy-reflection 1 }
- { deploy-word-defs? f }
+ { deploy-c-types? f }
{ deploy-io 2 }
- { deploy-word-props? f }
+ { deploy-reflection 1 }
+ { deploy-ui? f }
{ "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 2476077ba9..172a80b612 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -40,42 +40,57 @@ IN: tools.deploy.backend
"compiler" deploy-compiler? get ?,
"ui" deploy-ui? get ?,
"io" native-io? ?,
+ "random" deploy-random? get ?,
] { } make ;
-: staging-image-name ( -- name )
+: staging-image-name ( profile -- name )
"staging."
- bootstrap-profile strip-word-names? [ "strip" add ] when
- "-" join ".image" 3append ;
+ swap strip-word-names? [ "strip" add ] when
+ "-" join ".image" 3append temp-file ;
-: staging-command-line ( config -- flags )
+DEFER: ?make-staging-image
+
+: staging-command-line ( profile -- flags )
[
- [
+ dup empty? [
"-i=" my-boot-image-name append ,
+ ] [
+ dup 1 head* ?make-staging-image
- "-output-image=" staging-image-name append ,
+ "-resource-path=" "" resource-path append ,
- "-include=" bootstrap-profile " " join append ,
+ "-i=" over 1 head* staging-image-name append ,
- strip-word-names? [ "-no-stack-traces" , ] when
+ "-run=tools.deploy.restage" ,
+ ] if
- "-no-user-init" ,
- ] { } make
- ] bind ;
+ "-output-image=" over staging-image-name append ,
+
+ "-include=" swap " " join append ,
+
+ strip-word-names? [ "-no-stack-traces" , ] when
+
+ "-no-user-init" ,
+ ] { } make ;
: run-factor ( vm flags -- )
swap add* dup . run-with-output ; inline
-: make-staging-image ( config -- )
+: make-staging-image ( profile -- )
vm swap staging-command-line run-factor ;
-: ?make-staging-image ( config -- )
- dup [ staging-image-name ] bind exists?
+: ?make-staging-image ( profile -- )
+ dup staging-image-name exists?
[ drop ] [ make-staging-image ] if ;
: deploy-command-line ( image vocab config -- flags )
[
+ bootstrap-profile ?make-staging-image
+
[
- "-i=" staging-image-name append ,
+ "-i=" bootstrap-profile staging-image-name append ,
+
+ "-resource-path=" "" resource-path append ,
"-run=tools.deploy.shaker" ,
@@ -89,7 +104,6 @@ IN: tools.deploy.backend
: make-deploy-image ( vm image vocab config -- )
make-boot-image
- dup ?make-staging-image
deploy-command-line run-factor ;
SYMBOL: deploy-implementation
diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor
index 846bb5c274..4af1219daf 100755
--- a/extra/tools/deploy/config/config-docs.factor
+++ b/extra/tools/deploy/config/config-docs.factor
@@ -16,6 +16,8 @@ ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiler? }
+{ $subsection deploy-random? }
+{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
{ $subsection deploy-io }
@@ -66,16 +68,21 @@ HELP: deploy-math?
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
-HELP: deploy-threads?
-{ $description "Deploy flag. If set, the deployed image will contain support for threads."
-$nl
-"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
-
HELP: deploy-compiler?
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
+HELP: deploy-random?
+{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
+$nl
+"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
+
+HELP: deploy-threads?
+{ $description "Deploy flag. If set, thread support will be included in the final image."
+$nl
+"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
+
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
$nl
diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor
index c527cb945c..7ebedf7ca1 100755
--- a/extra/tools/deploy/config/config.factor
+++ b/extra/tools/deploy/config/config.factor
@@ -10,6 +10,7 @@ SYMBOL: deploy-name
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
+SYMBOL: deploy-random?
SYMBOL: deploy-threads?
SYMBOL: deploy-io
@@ -57,6 +58,7 @@ SYMBOL: deploy-image
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
+ { deploy-random? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
diff --git a/extra/tools/deploy/restage/restage.factor b/extra/tools/deploy/restage/restage.factor
new file mode 100644
index 0000000000..c75abf9dd3
--- /dev/null
+++ b/extra/tools/deploy/restage/restage.factor
@@ -0,0 +1,8 @@
+IN: tools.deploy.restage
+USING: bootstrap.stage2 namespaces memory ;
+
+: restage ( -- )
+ load-components
+ "output-image" get save-image-and-exit ;
+
+MAIN: restage
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index d31a3460ca..76e4a212b2 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -19,7 +19,6 @@ QUALIFIED: libc.private
QUALIFIED: libc.private
QUALIFIED: listener
QUALIFIED: prettyprint.config
-QUALIFIED: random
QUALIFIED: source-files
QUALIFIED: threads
QUALIFIED: vocabs
@@ -108,8 +107,6 @@ IN: tools.deploy.shaker
: stripped-globals ( -- seq )
[
- random:random-generator ,
-
{
bootstrap.stage2:bootstrap-time
continuations:error
@@ -145,12 +142,14 @@ IN: tools.deploy.shaker
vocabs:dictionary
lexer-factory
vocabs:load-vocab-hook
+ root-cache
layouts:num-tags
layouts:num-types
layouts:tag-mask
layouts:tag-numbers
layouts:type-numbers
classes:typemap
+ classes:class-map
vocab-roots
definitions:crossref
compiled-crossref
diff --git a/extra/tools/deploy/test/1/deploy.factor b/extra/tools/deploy/test/1/deploy.factor
index f06bcbc0f0..490c21a067 100755
--- a/extra/tools/deploy/test/1/deploy.factor
+++ b/extra/tools/deploy/test/1/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
+ { deploy-word-defs? f }
+ { deploy-random? f }
+ { deploy-name "tools.deploy.test.1" }
+ { deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
- { deploy-threads? t }
- { deploy-word-props? f }
- { deploy-word-defs? f }
- { deploy-name "tools.deploy.test.1" }
- { deploy-math? t }
- { deploy-compiler? t }
- { "stop-after-last-window?" t }
{ deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/tools/deploy/test/2/deploy.factor b/extra/tools/deploy/test/2/deploy.factor
index bd087d65bf..b8c37af20a 100755
--- a/extra/tools/deploy/test/2/deploy.factor
+++ b/extra/tools/deploy/test/2/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
+ { deploy-word-defs? f }
+ { deploy-random? f }
+ { deploy-name "tools.deploy.test.2" }
+ { deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
- { deploy-threads? t }
- { deploy-word-props? f }
- { deploy-word-defs? f }
- { deploy-name "tools.deploy.test.2" }
- { deploy-math? t }
- { deploy-compiler? t }
- { "stop-after-last-window?" t }
{ deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/tools/deploy/test/3/deploy.factor b/extra/tools/deploy/test/3/deploy.factor
index b8b8bf4aa2..dde8291658 100755
--- a/extra/tools/deploy/test/3/deploy.factor
+++ b/extra/tools/deploy/test/3/deploy.factor
@@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "tools.deploy.test.3" }
{ deploy-threads? t }
- { deploy-word-props? f }
- { "stop-after-last-window?" t }
- { deploy-ui? f }
- { deploy-io 3 }
{ deploy-compiler? t }
- { deploy-word-defs? f }
+ { deploy-math? t }
{ deploy-c-types? f }
+ { deploy-io 3 }
+ { deploy-reflection 1 }
+ { deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor
index 9aa763d7ec..eca5740bbc 100755
--- a/extra/ui/tools/deploy/deploy.factor
+++ b/extra/ui/tools/deploy/deploy.factor
@@ -35,6 +35,7 @@ TUPLE: deploy-gadget vocab settings ;
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
deploy-math? get "Rational and complex number support" <checkbox> gadget,
deploy-threads? get "Threading support" <checkbox> gadget,
+ deploy-random? get "Random number generator support" <checkbox> gadget,
deploy-word-props? get "Retain all word properties" <checkbox> gadget,
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
From dea825331a45189a54e0fd57dd19d7c302bdebb2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 21:35:01 -0500
Subject: [PATCH 173/197] Fix tools.deploy tests
---
extra/tools/deploy/deploy-tests.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 3b88d14fb3..8db34320de 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -28,7 +28,8 @@ namespaces ;
[ ] [ "hello-ui" shake-and-bake ] unit-test
[ "staging.math-compiler-ui-strip.image" ] [
- "hello-ui" deploy-config [ staging-image-name ] bind
+ "hello-ui" deploy-config
+ [ bootstrap-profile staging-image-name file-name ] bind
] unit-test
[ t ] [
From 0d86affd2a3b5c273e2897a65a0ca34e5fd9762a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 21:35:32 -0500
Subject: [PATCH 174/197] Fix
---
extra/hello-ui/deploy.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor
index 0ec9c19503..31f1181be2 100755
--- a/extra/hello-ui/deploy.factor
+++ b/extra/hello-ui/deploy.factor
@@ -1,7 +1,7 @@
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
- { deploy-random? t }
+ { deploy-random? f }
{ deploy-name "Hello world" }
{ deploy-threads? t }
{ deploy-compiler? t }
From a614e2e8e4d83f161dcf3aa17d59a86795a424ec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 21:55:40 -0500
Subject: [PATCH 175/197] Minor documentation updates
---
core/compiler/compiler-docs.factor | 3 ++-
core/compiler/units/units-docs.factor | 4 +++-
core/syntax/syntax-docs.factor | 3 +++
3 files changed, 8 insertions(+), 2 deletions(-)
diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor
index 7196a4b4fb..3520104e1f 100755
--- a/core/compiler/compiler-docs.factor
+++ b/core/compiler/compiler-docs.factor
@@ -8,7 +8,8 @@ $nl
"The main entry point to the optimizing compiler:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
-{ $subsection decompile } ;
+{ $subsection decompile }
+"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor
index 74dac17be8..09baf91018 100755
--- a/core/compiler/units/units-docs.factor
+++ b/core/compiler/units/units-docs.factor
@@ -9,7 +9,9 @@ $nl
$nl
"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:"
{ $subsection with-compilation-unit }
-"Words called to associate a definition with a source file location:"
+"Compiling a set of words:"
+{ $subsection compile }
+"Words called to associate a definition with a compilation unit and a source file location:"
{ $subsection remember-definition }
{ $subsection remember-class }
"Forward reference checking (see " { $link "definition-checking" } "):"
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 26562a2178..c0ceb4119a 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -227,6 +227,9 @@ HELP: foldable
}
"The last restriction ensures that words such as " { $link clone } " do not satisfy the foldable word contract. Indeed, " { $link clone } " will output a mutable object if its input is mutable, and so it is undesirable to evaluate it at compile-time, since doing so would give incorrect semantics for code that clones mutable objects and proceeds to mutate them."
}
+{ $notes
+ "Folding optimizations are not applied if the call site of a word is in the same source file as the word. This is a side-effect of the compilation unit system; see " { $link "compilation-units" } "."
+}
{ $examples "Most operations on numbers are foldable. For example, " { $snippet "2 2 +" } " compiles to a literal 4, since " { $link + } " is declared foldable." } ;
HELP: flushable
From c0c9479196cca03c35183013f89c2ec964b80525 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 16:57:13 -0500
Subject: [PATCH 176/197] add file-info test
---
core/io/files/files-tests.factor | 15 ++++++++++++++-
1 file changed, 14 insertions(+), 1 deletion(-)
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index e347e3e3d6..739b55882d 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,5 +1,6 @@
IN: io.files.tests
-USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
+USING: tools.test io.files io threads kernel continuations io.encodings.ascii
+io.files.unique sequences strings accessors ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
@@ -131,3 +132,15 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
+
+
+
+[ 123 ] [
+ "core" ".test" [
+ [
+ ascii [
+ 123 CHAR: a <repetition> >string write
+ ] with-file-writer
+ ] keep file-info size>>
+ ] with-unique-file
+] unit-test
From a96074997589c0e9b0c3e467355f53482990e605 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 16 Mar 2008 17:07:43 -0500
Subject: [PATCH 177/197] fix openbsd types
---
extra/unix/stat/openbsd/32/32.factor | 29 --------------------
extra/unix/stat/openbsd/64/64.factor | 29 --------------------
extra/unix/stat/openbsd/openbsd.factor | 32 ++++++++++++++++++----
extra/unix/types/openbsd/32/32.factor | 29 --------------------
extra/unix/types/openbsd/64/64.factor | 29 --------------------
extra/unix/types/openbsd/openbsd.factor | 36 ++++++++++++++++++++-----
6 files changed, 57 insertions(+), 127 deletions(-)
delete mode 100644 extra/unix/stat/openbsd/32/32.factor
delete mode 100644 extra/unix/stat/openbsd/64/64.factor
delete mode 100755 extra/unix/types/openbsd/32/32.factor
delete mode 100755 extra/unix/types/openbsd/64/64.factor
mode change 100644 => 100755 extra/unix/types/openbsd/openbsd.factor
diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor
deleted file mode 100644
index 61a37ba567..0000000000
--- a/extra/unix/stat/openbsd/32/32.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-USING: kernel alien.syntax math ;
-IN: unix.stat
-
-! OpenBSD 4.2
-
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "int32_t" "st_lspare0" }
- { "timespec*" "st_atim" }
- { "timespec*" "st_mtim" }
- { "timespec*" "st_ctim" }
- { "off_t" "st_size" }
- { "int64_t" "st_blocks" }
- { "u_int32_t" "st_blksize" }
- { "u_int32_t" "st_flags" }
- { "u_int32_t" "st_gen" }
- { "int32_t" "st_lspare1" }
- { "timespec*" "st_birthtim" }
- { "int64_t" "st_qspare1" }
- { "int64_t" "st_qspare2" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor
deleted file mode 100644
index 61a37ba567..0000000000
--- a/extra/unix/stat/openbsd/64/64.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-USING: kernel alien.syntax math ;
-IN: unix.stat
-
-! OpenBSD 4.2
-
-C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { "int32_t" "st_lspare0" }
- { "timespec*" "st_atim" }
- { "timespec*" "st_mtim" }
- { "timespec*" "st_ctim" }
- { "off_t" "st_size" }
- { "int64_t" "st_blocks" }
- { "u_int32_t" "st_blksize" }
- { "u_int32_t" "st_flags" }
- { "u_int32_t" "st_gen" }
- { "int32_t" "st_lspare1" }
- { "timespec*" "st_birthtim" }
- { "int64_t" "st_qspare1" }
- { "int64_t" "st_qspare2" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor
index 0a2312302b..38ebf66abc 100644
--- a/extra/unix/stat/openbsd/openbsd.factor
+++ b/extra/unix/stat/openbsd/openbsd.factor
@@ -1,7 +1,29 @@
-USING: layouts combinators vocabs.loader ;
+USING: kernel alien.syntax math ;
IN: unix.stat
-cell-bits {
- { 32 [ "unix.stat.openbsd.32" require ] }
- { 64 [ "unix.stat.openbsd.64" require ] }
-} case
+! OpenBSD 4.2
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "int32_t" "st_lspare0" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "int64_t" "st_blocks" }
+ { "u_int32_t" "st_blksize" }
+ { "u_int32_t" "st_flags" }
+ { "u_int32_t" "st_gen" }
+ { "int32_t" "st_lspare1" }
+ { "timespec" "st_birthtim" }
+ { "int64_t" "st_qspare1" }
+ { "int64_t" "st_qspare2" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/types/openbsd/32/32.factor b/extra/unix/types/openbsd/32/32.factor
deleted file mode 100755
index 221f9896b0..0000000000
--- a/extra/unix/types/openbsd/32/32.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-USING: alien.syntax ;
-IN: unix.types
-
-! OpenBSD 4.2
-
-TYPEDEF: ushort __uint16_t
-TYPEDEF: uint __uint32_t
-TYPEDEF: int __int32_t
-TYPEDEF: longlong __int64_t
-
-TYPEDEF: int int32_t
-TYPEDEF: int u_int32_t
-TYPEDEF: longlong int64_t
-TYPEDEF: ulonglong u_int64_t
-
-TYPEDEF: __uint32_t __dev_t
-TYPEDEF: __uint32_t dev_t
-TYPEDEF: __uint32_t ino_t
-TYPEDEF: __uint16_t mode_t
-TYPEDEF: __uint16_t nlink_t
-TYPEDEF: __uint32_t uid_t
-TYPEDEF: __uint32_t gid_t
-TYPEDEF: __int64_t off_t
-TYPEDEF: __int64_t blkcnt_t
-TYPEDEF: __uint32_t blksize_t
-TYPEDEF: __uint32_t fflags_t
-TYPEDEF: int ssize_t
-TYPEDEF: int pid_t
-TYPEDEF: int time_t
diff --git a/extra/unix/types/openbsd/64/64.factor b/extra/unix/types/openbsd/64/64.factor
deleted file mode 100755
index b24cc94a90..0000000000
--- a/extra/unix/types/openbsd/64/64.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-USING: alien.syntax ;
-IN: unix.types
-
-! OpenBSD 4.2
-
-TYPEDEF: ushort __uint16_t
-TYPEDEF: uint __uint32_t
-TYPEDEF: int __int32_t
-TYPEDEF: longlong __int64_t
-
-TYPEDEF: int int32_t
-TYPEDEF: int u_int32_t
-TYPEDEF: longlong int64_t
-TYPEDEF: ulonglong u_int64_t
-
-TYPEDEF: __uint32_t __dev_t
-TYPEDEF: __uint32_t dev_t
-TYPEDEF: __uint32_t ino_t
-TYPEDEF: __uint32_t mode_t
-TYPEDEF: __uint32_t nlink_t
-TYPEDEF: __uint32_t uid_t
-TYPEDEF: __uint32_t gid_t
-TYPEDEF: __uint64_t off_t
-TYPEDEF: __uint64_t blkcnt_t
-TYPEDEF: __uint32_t blksize_t
-TYPEDEF: __uint32_t fflags_t
-TYPEDEF: int ssize_t
-TYPEDEF: int pid_t
-TYPEDEF: int time_t
diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor
old mode 100644
new mode 100755
index 9d2508e91c..7445dada2b
--- a/extra/unix/types/openbsd/openbsd.factor
+++ b/extra/unix/types/openbsd/openbsd.factor
@@ -1,7 +1,31 @@
-USING: layouts combinators vocabs.loader ;
-IN: unix.stat
+USING: alien.syntax ;
+IN: unix.types
-cell-bits {
- { 32 [ "unix.types.openbsd.32" require ] }
- { 64 [ "unix.types.openbsd.64" require ] }
-} case
+! OpenBSD 4.2
+
+TYPEDEF: short __int16_t
+TYPEDEF: ushort __uint16_t
+TYPEDEF: int __int32_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: longlong __int64_t
+TYPEDEF: longlong __uint64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: int u_int32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint32_t mode_t
+TYPEDEF: __uint32_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
From 84c327d60634ac9dbb8c42a5fff358efbb8b6acb Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 23:32:48 -0500
Subject: [PATCH 178/197] fix help lint error
---
extra/io/files/unique/unique-docs.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor
index fcfcc15678..01b8e131cc 100644
--- a/extra/io/files/unique/unique-docs.factor
+++ b/extra/io/files/unique/unique-docs.factor
@@ -12,7 +12,7 @@ ARTICLE: "unique" "Making and using unique files"
ABOUT: "unique"
-HELP: make-unique-file ( prefix suffix -- path stream )
+HELP: make-unique-file ( prefix suffix -- path )
{ $values { "prefix" "a string" } { "suffix" "a string" }
{ "path" "a pathname string" } }
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
@@ -26,7 +26,8 @@ HELP: make-unique-directory ( -- path )
{ $see-also with-unique-directory } ;
HELP: with-unique-file ( prefix suffix quot -- )
-{ $values { "quot" "a quotation" } }
+{ $values { "prefix" "a string" } { "suffix" "a string" }
+{ "quot" "a quotation" } }
{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
{ $notes "The unique file will be deleted after calling this word." } ;
From 9584be29817d738b6f7054f7e685de12068a325f Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@possum.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 18:02:19 -0500
Subject: [PATCH 179/197] finally fix openbsd stat
---
extra/unix/stat/openbsd/openbsd.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor
index 38ebf66abc..decfb0dbb1 100644
--- a/extra/unix/stat/openbsd/openbsd.factor
+++ b/extra/unix/stat/openbsd/openbsd.factor
@@ -22,8 +22,7 @@ C-STRUCT: stat
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
{ "timespec" "st_birthtim" }
- { "int64_t" "st_qspare1" }
- { "int64_t" "st_qspare2" } ;
+ { { "int64_t" 2 } "st_qspare" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
From d1e72fd03b8cf8bcf57c2e077b6dc967e7f45548 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@freebsd.gateway.2wire.net>
Date: Thu, 20 Mar 2008 23:53:05 -0500
Subject: [PATCH 180/197] make freebsd64 compile
---
vm/os-freebsd-x86.64.h | 9 +++++++++
vm/platform.h | 2 ++
2 files changed, 11 insertions(+)
create mode 100644 vm/os-freebsd-x86.64.h
diff --git a/vm/os-freebsd-x86.64.h b/vm/os-freebsd-x86.64.h
new file mode 100644
index 0000000000..23e1ff5733
--- /dev/null
+++ b/vm/os-freebsd-x86.64.h
@@ -0,0 +1,9 @@
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_rsp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
diff --git a/vm/platform.h b/vm/platform.h
index 66f22bbf96..cd2b6e0a0e 100644
--- a/vm/platform.h
+++ b/vm/platform.h
@@ -49,6 +49,8 @@
#if defined(FACTOR_X86)
#include "os-freebsd-x86.32.h"
+ #elif defined(FACTOR_AMD64)
+ #include "os-freebsd-x86.64.h"
#else
#error "Unsupported FreeBSD flavor"
#endif
From 2bdfc463318785384676c613d19a5635ff56788f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 21 Mar 2008 00:31:00 -0500
Subject: [PATCH 181/197] Move bitmaps
---
extra/graphics/bitmap/bitmap.factor | 8 ++++----
.../graphics/bitmap/test-images}/1bit.bmp | Bin
.../graphics/bitmap/test-images}/rgb4bit.bmp | Bin
.../graphics/bitmap/test-images}/rgb8bit.bmp | Bin
.../graphics/bitmap/test-images}/thiswayup24.bmp | Bin
5 files changed, 4 insertions(+), 4 deletions(-)
mode change 100644 => 100755 extra/graphics/bitmap/bitmap.factor
rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/1bit.bmp (100%)
rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/rgb4bit.bmp (100%)
rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/rgb8bit.bmp (100%)
rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/thiswayup24.bmp (100%)
diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
old mode 100644
new mode 100755
index ec4d6b79e1..861894c8f4
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -117,16 +117,16 @@ M: bitmap height ( bitmap -- ) bitmap-height ;
load-bitmap [ <graphics-gadget> "bitmap" open-window ] keep ;
: test-bitmap24 ( -- )
- "misc/graphics/bmps/thiswayup24.bmp" resource-path bitmap. ;
+ "extra/graphics/bitmap/test-data/thiswayup24.bmp" resource-path bitmap. ;
: test-bitmap8 ( -- )
- "misc/graphics/bmps/rgb8bit.bmp" resource-path bitmap. ;
+ "extra/graphics/bitmap/test-data/rgb8bit.bmp" resource-path bitmap. ;
: test-bitmap4 ( -- )
- "misc/graphics/bmps/rgb4bit.bmp" resource-path
+ "extra/graphics/bitmap/test-data/rgb4bit.bmp" resource-path
load-bitmap ;
! bitmap. ;
: test-bitmap1 ( -- )
- "misc/graphics/bmps/1bit.bmp" resource-path bitmap. ;
+ "extra/graphics/bitmap/test-data/1bit.bmp" resource-path bitmap. ;
diff --git a/misc/graphics/bmps/1bit.bmp b/extra/graphics/bitmap/test-images/1bit.bmp
similarity index 100%
rename from misc/graphics/bmps/1bit.bmp
rename to extra/graphics/bitmap/test-images/1bit.bmp
diff --git a/misc/graphics/bmps/rgb4bit.bmp b/extra/graphics/bitmap/test-images/rgb4bit.bmp
similarity index 100%
rename from misc/graphics/bmps/rgb4bit.bmp
rename to extra/graphics/bitmap/test-images/rgb4bit.bmp
diff --git a/misc/graphics/bmps/rgb8bit.bmp b/extra/graphics/bitmap/test-images/rgb8bit.bmp
similarity index 100%
rename from misc/graphics/bmps/rgb8bit.bmp
rename to extra/graphics/bitmap/test-images/rgb8bit.bmp
diff --git a/misc/graphics/bmps/thiswayup24.bmp b/extra/graphics/bitmap/test-images/thiswayup24.bmp
similarity index 100%
rename from misc/graphics/bmps/thiswayup24.bmp
rename to extra/graphics/bitmap/test-images/thiswayup24.bmp
From 15a747cce4fa195a73a1c028470aaa9dbec470f8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 21 Mar 2008 00:37:27 -0500
Subject: [PATCH 182/197] Move things around a bit
---
Makefile | 8 ++++----
{misc => build-support}/target | 0
{misc => build-support}/wordsize.c | 0
3 files changed, 4 insertions(+), 4 deletions(-)
rename {misc => build-support}/target (100%)
rename {misc => build-support}/wordsize.c (100%)
diff --git a/Makefile b/Makefile
index 054d57b641..ecb333a0b2 100755
--- a/Makefile
+++ b/Makefile
@@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS)
-default: misc/wordsize
- $(MAKE) `./misc/target`
+default: build-support/wordsize
+ $(MAKE) `./build-support/target`
help:
@echo "Run '$(MAKE)' with one of the following parameters:"
@@ -162,8 +162,8 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
-misc/wordsize: misc/wordsize.c
- gcc misc/wordsize.c -o misc/wordsize
+build-support/wordsize: build-support/wordsize.c
+ gcc build-support/wordsize.c -o build-support/wordsize
clean:
rm -f vm/*.o
diff --git a/misc/target b/build-support/target
similarity index 100%
rename from misc/target
rename to build-support/target
diff --git a/misc/wordsize.c b/build-support/wordsize.c
similarity index 100%
rename from misc/wordsize.c
rename to build-support/wordsize.c
From b84055515737e22e45a4cd9d8edad487a0d4d699 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 21 Mar 2008 00:37:58 -0500
Subject: [PATCH 183/197] Clean things up for binary releases
---
{misc => build-support}/grovel.c | 0
core/io/files/files-tests.factor | 2 +-
misc/version.sh | 1 -
3 files changed, 1 insertion(+), 2 deletions(-)
rename {misc => build-support}/grovel.c (100%)
delete mode 100644 misc/version.sh
diff --git a/misc/grovel.c b/build-support/grovel.c
similarity index 100%
rename from misc/grovel.c
rename to build-support/grovel.c
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index 739b55882d..4cda463983 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -131,7 +131,7 @@ io.files.unique sequences strings accessors ;
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
-[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
+[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
diff --git a/misc/version.sh b/misc/version.sh
deleted file mode 100644
index 9c5d02d463..0000000000
--- a/misc/version.sh
+++ /dev/null
@@ -1 +0,0 @@
-export VERSION=0.92
From 95e960c6eccd6b0b8cefe4e1eab6643e62bacd9b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 21 Mar 2008 00:39:28 -0500
Subject: [PATCH 184/197] Fix target script
---
build-support/target | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/build-support/target b/build-support/target
index c9f927a507..239862c3ae 100755
--- a/build-support/target
+++ b/build-support/target
@@ -17,7 +17,7 @@ then
echo macosx-ppc
elif [ `uname -s` = Darwin ]
then
- echo macosx-x86-`./misc/wordsize`
+ echo macosx-x86-`./build-support/wordsize`
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
then
echo linux-x86-32
@@ -26,7 +26,7 @@ then
echo linux-x86-64
elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
then
- echo winnt-x86-`./misc/wordsize`
+ echo winnt-x86-`./build-support/wordsize`
else
echo help
fi
From 7c83016eee55c4bb381f682c375d440fe23eaadd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 21 Mar 2008 00:40:02 -0500
Subject: [PATCH 185/197] Update .gitignore
---
.gitignore | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/.gitignore b/.gitignore
index 19ace1f500..7e1e52d866 100644
--- a/.gitignore
+++ b/.gitignore
@@ -18,4 +18,4 @@ factor
temp
logs
work
-misc/wordsize
\ No newline at end of file
+buildsupport/wordsize
From 2da79d04fdb43dfda90ecadc1ac0e655203fc949 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 19:11:01 -0500
Subject: [PATCH 186/197] add some constants to grovel
---
build-support/grovel.c | 37 +++++++++++++++++++++++++++++++++----
1 file changed, 33 insertions(+), 4 deletions(-)
diff --git a/build-support/grovel.c b/build-support/grovel.c
index 2e39d2495e..2b8aad2e5f 100644
--- a/build-support/grovel.c
+++ b/build-support/grovel.c
@@ -32,9 +32,12 @@
#if defined(UNIX)
#include <sys/types.h>
#include <sys/stat.h>
+ #include <sys/socket.h>
+ #include <sys/errno.h>
+ #include <fcntl.h>
+ #include <unistd.h>
#endif
-
#define BL printf(" ");
#define QUOT printf("\"");
#define NL printf("\n");
@@ -50,6 +53,7 @@
#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL
#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL
#define struct(n) printf("C-STRUCT: %s\n", (n));
+#define constant(n) printf("#define "); printf(#n); printf(" %d (HEX: %04x)", (n), (n)); NL
void openbsd_types()
{
@@ -79,9 +83,9 @@ void openbsd_stat()
grovel2(gid_t, "st_gid");
grovel2(dev_t, "st_rdev");
grovel2(int32_t, "st_lspare0");
- grovel2(struct timespec, "st_atimespec");
- grovel2(struct timespec, "st_mtimespec");
- grovel2(struct timespec, "st_ctimespec");
+ grovel2(struct timespec, "st_atim");
+ grovel2(struct timespec, "st_mtim");
+ grovel2(struct timespec, "st_ctim");
grovel2(off_t, "st_size");
grovel2(int64_t, "st_blocks");
grovel2(u_int32_t, "st_blksize");
@@ -109,6 +113,28 @@ void unix_types()
grovel(time_t);
grovel(uid_t);
}
+
+void unix_constants()
+{
+ constant(O_RDONLY);
+ constant(O_WRONLY);
+ constant(O_RDWR);
+ constant(O_APPEND);
+ constant(O_CREAT);
+ constant(O_TRUNC);
+ constant(O_EXCL);
+ constant(FD_SETSIZE);
+ constant(SOL_SOCKET);
+ constant(SO_REUSEADDR);
+ constant(SO_OOBINLINE);
+ constant(SO_SNDTIMEO);
+ constant(SO_RCVTIMEO);
+ constant(F_SETFL);
+ constant(O_NONBLOCK);
+ constant(EINTR);
+ constant(EAGAIN);
+ constant(EINPROGRESS);
+}
int main() {
//grovel(char);
@@ -121,6 +147,7 @@ int main() {
//grovel(void*);
//grovel(char*);
+
#ifdef FREEBSD
grovel(blkcnt_t);
grovel(blksize_t);
@@ -134,8 +161,10 @@ int main() {
#ifdef UNIX
unix_types();
+ unix_constants();
#endif
grovel(long);
return 0;
}
+
From 327c07b67e82ad187989e552db1c0d457e948fea Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 19:11:04 -0500
Subject: [PATCH 187/197] make md5 work on netbsd in factor.sh
---
misc/factor.sh | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/misc/factor.sh b/misc/factor.sh
index b96aa8d24b..276956b0b7 100755
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -306,7 +306,10 @@ update_boot_images() {
get_url http://factorcode.org/images/latest/checksums.txt
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
set_md5sum
- disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
+ case $OS in
+ netbsd) disk_md5=`md5 $BOOT_IMAGE | cut -f4 -d' '`;;
+ *) disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '` ;;
+ esac
echo "Factorcode md5: $factorcode_md5";
echo "Disk md5: $disk_md5";
if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
From 36d02462ce41218c1e9dab42e754dd6ef741f89c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 19:12:06 -0500
Subject: [PATCH 188/197] add netbsd to targets add stat/types for netbsd fix
type for openbsd
---
build-support/target | 6 +++++
extra/unix/stat/netbsd/netbsd.factor | 26 ++++++++++++++++++++
extra/unix/types/netbsd/netbsd.factor | 32 +++++++++++++++++++++++++
extra/unix/types/openbsd/openbsd.factor | 3 ++-
4 files changed, 66 insertions(+), 1 deletion(-)
create mode 100644 extra/unix/stat/netbsd/netbsd.factor
create mode 100755 extra/unix/types/netbsd/netbsd.factor
diff --git a/build-support/target b/build-support/target
index 239862c3ae..8e07c1afdc 100755
--- a/build-support/target
+++ b/build-support/target
@@ -12,6 +12,12 @@ then
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ]
then
echo openbsd-x86-64
+elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ]
+then
+ echo netbsd-x86-32
+elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = amd64 \) ]
+then
+ echo netbsd-x86-64
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
then
echo macosx-ppc
diff --git a/extra/unix/stat/netbsd/netbsd.factor b/extra/unix/stat/netbsd/netbsd.factor
new file mode 100644
index 0000000000..bb2df6d6d3
--- /dev/null
+++ b/extra/unix/stat/netbsd/netbsd.factor
@@ -0,0 +1,26 @@
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! NetBSD 4.0
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "mode_t" "st_mode" }
+ { "ino_t" "st_ino" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "timespec" "st_birthtim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "uint32_t" "st_flags" }
+ { "uint32_t" "st_gen" }
+ { { "uint32_t" 2 } "st_qspare" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor
new file mode 100755
index 0000000000..d65bcb3d33
--- /dev/null
+++ b/extra/unix/types/netbsd/netbsd.factor
@@ -0,0 +1,32 @@
+USING: alien.syntax ;
+IN: unix.types
+
+! NetBSD 4.0
+
+TYPEDEF: short __int16_t
+TYPEDEF: ushort __uint16_t
+TYPEDEF: int __int32_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: longlong __int64_t
+TYPEDEF: longlong __uint64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: uint uint32_t
+TYPEDEF: uint u_int32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint32_t mode_t
+TYPEDEF: __uint32_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor
index 7445dada2b..5bdda212d8 100755
--- a/extra/unix/types/openbsd/openbsd.factor
+++ b/extra/unix/types/openbsd/openbsd.factor
@@ -11,7 +11,8 @@ TYPEDEF: longlong __int64_t
TYPEDEF: longlong __uint64_t
TYPEDEF: int int32_t
-TYPEDEF: int u_int32_t
+TYPEDEF: uint u_int32_t
+TYPEDEF: uint uint32_t
TYPEDEF: longlong int64_t
TYPEDEF: ulonglong u_int64_t
From 9402b9b11ed82e5499c20bb58ee7d3eb0c7e77c0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 20 Mar 2008 19:15:16 -0500
Subject: [PATCH 189/197] fix stat on netbsd
---
extra/unix/types/netbsd/netbsd.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor
index d65bcb3d33..77636a6d6d 100755
--- a/extra/unix/types/netbsd/netbsd.factor
+++ b/extra/unix/types/netbsd/netbsd.factor
@@ -18,7 +18,7 @@ TYPEDEF: ulonglong u_int64_t
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
-TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint64_t ino_t
TYPEDEF: __uint32_t mode_t
TYPEDEF: __uint32_t nlink_t
TYPEDEF: __uint32_t uid_t
From 4e2c5f2d5998123b178d39dcd06e29893454e7be Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@self.internal.stack-effects.com>
Date: Thu, 20 Mar 2008 19:55:46 -0500
Subject: [PATCH 190/197] delete comments
---
build-support/grovel.c | 13 -------------
1 file changed, 13 deletions(-)
diff --git a/build-support/grovel.c b/build-support/grovel.c
index 2b8aad2e5f..600865cf39 100644
--- a/build-support/grovel.c
+++ b/build-support/grovel.c
@@ -137,17 +137,6 @@ void unix_constants()
}
int main() {
- //grovel(char);
- //grovel(int);
- //grovel(uint);
- //grovel(long);
- //grovel(ulong);
- //grovel(long long);
- //grovel(unsigned long long);
- //grovel(void*);
- //grovel(char*);
-
-
#ifdef FREEBSD
grovel(blkcnt_t);
grovel(blksize_t);
@@ -164,7 +153,5 @@ int main() {
unix_constants();
#endif
- grovel(long);
return 0;
}
-
From f1e17f290656ba845cb2849a531b79e7af8d22be Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 7 Apr 2007 20:04:39 -0500
Subject: [PATCH 191/197] fix netbsd64 target
---
build-support/target | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/build-support/target b/build-support/target
index 8e07c1afdc..1903a6da64 100755
--- a/build-support/target
+++ b/build-support/target
@@ -15,7 +15,7 @@ then
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ]
then
echo netbsd-x86-32
-elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = amd64 \) ]
+elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ]
then
echo netbsd-x86-64
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
From 9018a9093fd4f2f39d942bf9d369f4667a4b57d5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Mar 2008 11:52:47 -0600
Subject: [PATCH 192/197] fix using
---
extra/io/windows/files/unique/unique.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor
index 112dea48a7..7e7610eb72 100644
--- a/extra/io/windows/files/unique/unique.factor
+++ b/extra/io/windows/files/unique/unique.factor
@@ -1,5 +1,5 @@
USING: kernel system io.files.unique.backend
-windows.kernel32 io.windows io.nonblocking ;
+windows.kernel32 io.windows io.nonblocking windows ;
IN: io.windows.files.unique
M: windows-io (make-unique-file) ( path -- )
From 17356ece95cbb36a4079799048a06dc54f6cbd2d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Mar 2008 14:22:57 -0500
Subject: [PATCH 193/197] dont error on USE: unix
---
extra/unix/types/types.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor
index ed2dbd5ba8..983d5d677d 100644
--- a/extra/unix/types/types.factor
+++ b/extra/unix/types/types.factor
@@ -12,5 +12,6 @@ os
{ "freebsd" [ "unix.types.freebsd" require ] }
{ "openbsd" [ "unix.types.openbsd" require ] }
{ "netbsd" [ "unix.types.netbsd" require ] }
+ { "winnt" [ ] }
}
case
From 9c745c44d32284c4daf9d517429b96b4823f3d0b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Mar 2008 14:53:11 -0500
Subject: [PATCH 194/197] add set-priority and get-priority add clear_err_no
and check-errno for dealing with get-priority
---
extra/io/priority/priority.factor | 5 +++++
extra/io/unix/backend/backend.factor | 3 +++
extra/io/unix/priority/priority.factor | 21 +++++++++++++++++++++
extra/io/unix/unix.factor | 2 +-
extra/unix/unix.factor | 1 +
vm/io.c | 5 +++++
vm/io.h | 1 +
7 files changed, 37 insertions(+), 1 deletion(-)
create mode 100644 extra/io/priority/priority.factor
create mode 100644 extra/io/unix/priority/priority.factor
diff --git a/extra/io/priority/priority.factor b/extra/io/priority/priority.factor
new file mode 100644
index 0000000000..0790563072
--- /dev/null
+++ b/extra/io/priority/priority.factor
@@ -0,0 +1,5 @@
+USING: io.backend kernel ;
+IN: io.priority
+
+HOOK: get-priority io-backend ( -- n )
+HOOK: set-priority io-backend ( n -- )
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 93691c63e2..c9bd331bcd 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -72,6 +72,9 @@ M: mx unregister-io-task ( task mx -- )
: (io-error) ( -- * ) err_no strerror throw ;
+: check-errno ( -- )
+ err_no dup zero? [ drop ] [ strerror throw ] if ;
+
: check-null ( n -- ) zero? [ (io-error) ] when ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
diff --git a/extra/io/unix/priority/priority.factor b/extra/io/unix/priority/priority.factor
new file mode 100644
index 0000000000..deb801e3cf
--- /dev/null
+++ b/extra/io/unix/priority/priority.factor
@@ -0,0 +1,21 @@
+USING: alien.syntax kernel io.priority io.unix.backend
+unix ;
+IN: io.unix.priority
+
+: PRIO_PROCESS 0 ; inline
+: PRIO_PGRP 1 ; inline
+: PRIO_USER 2 ; inline
+
+: PRIO_MIN -20 ; inline
+: PRIO_MAX 20 ; inline
+
+! which/who = 0 for current process
+FUNCTION: int getpriority ( int which, int who ) ;
+FUNCTION: int setpriority ( int which, int who, int prio ) ;
+
+M: unix-io get-priority ( -- n )
+ clear_err_no
+ 0 0 getpriority dup -1 = [ check-errno ] when ;
+
+M: unix-io set-priority ( n -- )
+ 0 0 rot setpriority io-error ;
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 1f0492a060..83a455c29a 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
-io.unix.launcher io.unix.mmap io.backend
+io.unix.launcher io.unix.mmap io.backend io.priority
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index e1d49b8c6c..09d77fee11 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -27,6 +27,7 @@ TYPEDEF: ulong size_t
! ! ! Unix functions
LIBRARY: factor
FUNCTION: int err_no ( ) ;
+FUNCTION: void clear_err_no ( ) ;
LIBRARY: libc
diff --git a/vm/io.c b/vm/io.c
index faf681bbef..bc561f5e5b 100755
--- a/vm/io.c
+++ b/vm/io.c
@@ -194,3 +194,8 @@ int err_no(void)
{
return errno;
}
+
+void clear_err_no(void)
+{
+ errno = 0;
+}
diff --git a/vm/io.h b/vm/io.h
index 6291db50ee..f4af9b8bec 100755
--- a/vm/io.h
+++ b/vm/io.h
@@ -1,6 +1,7 @@
void init_c_io(void);
void io_error(void);
int err_no(void);
+void clear_err_no(void);
DECLARE_PRIMITIVE(fopen);
DECLARE_PRIMITIVE(fgetc);
From 08fe32a26865785c27aad5dc35eec1b69f370934 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Mar 2008 15:25:18 -0500
Subject: [PATCH 195/197] fix priority loading
---
extra/io/unix/unix.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 83a455c29a..bd58761a5b 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
-io.unix.launcher io.unix.mmap io.backend io.priority
+io.unix.launcher io.unix.mmap io.backend io.unix.priority
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
From bd89b4eb12e8a88ca540717c9a125b82a070a4f4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Mar 2008 23:21:02 -0500
Subject: [PATCH 196/197] mmap constants
---
build-support/grovel.c | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/build-support/grovel.c b/build-support/grovel.c
index 600865cf39..8422ec197c 100644
--- a/build-support/grovel.c
+++ b/build-support/grovel.c
@@ -12,12 +12,18 @@
#define UNIX
#endif
-#if (__OpenBSD__)
+#if defined(__OpenBSD__)
#define BSD
#define OPENBSD
#define UNIX
#endif
+#if defined(__APPLE__)
+ #define BSD
+ #define MACOSX
+ #define UNIX
+#endif
+
#if defined(linux)
#define LINUX
#define UNIX
@@ -34,6 +40,7 @@
#include <sys/stat.h>
#include <sys/socket.h>
#include <sys/errno.h>
+ #include <sys/mman.h>
#include <fcntl.h>
#include <unistd.h>
#endif
@@ -134,6 +141,10 @@ void unix_constants()
constant(EINTR);
constant(EAGAIN);
constant(EINPROGRESS);
+ constant(PROT_READ);
+ constant(PROT_WRITE);
+ constant(MAP_FILE);
+ constant(MAP_SHARED);
}
int main() {
From 3d1ba04462461f7d89fe3419b166f95bd56a9a89 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Mar 2008 01:21:21 -0500
Subject: [PATCH 197/197] add remove-nth
---
extra/sequences/lib/lib.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index a6b6b73148..0b93552e76 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -225,3 +225,6 @@ PRIVATE>
: replace ( str oldseq newseq -- str' )
H{ } 2seq>assoc substitute ;
+
+: remove-nth ( seq n -- seq' )
+ cut-slice 1 tail-slice append ;