From f7ec7cbc441f26ca39bfe4029245d9fb23099db9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 Feb 2008 18:08:01 -0800 Subject: [PATCH 01/28] 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 -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" - [ 0 swap glGetAttachedShaders ] keep - ] keep c-uint-array> ; + dup gl-program-shaders-length + dup "GLuint" + 0 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 + + + +: 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" [ CLSIDFromString ole32-error ] keep ; +: guid>string ( guid -- string ) + GUID-STRING-LENGTH 1+ [ "ushort" ] 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 Date: Fri, 15 Feb 2008 22:51:52 -0800 Subject: [PATCH 02/28] 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 -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" 0 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" [ CLSIDFromString ole32-error ] keep ; : guid>string ( guid -- string ) GUID-STRING-LENGTH 1+ [ "ushort" ] 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 Date: Wed, 12 Mar 2008 22:21:37 -0700 Subject: [PATCH 03/28] 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 56afb67bfc22f72b712a4e196f4fed6be77ea4fa Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 14 Mar 2008 03:09:51 -0500 Subject: [PATCH 04/28] 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 drop ; +M: binary 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: ( stream decoding -- newstream ) + +GENERIC: ( stream encoding -- newstream ) + +: replacement-char HEX: fffd ; ! Decoding + construct-empty ; +M: tuple 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 -rot decode-read-loop ; - -TUPLE: decoder code cr ; -: ( 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 [ + [ + >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 ; -: ( stream encoding -- newstream ) - dup binary eq? [ drop ] [ - construct-empty { set-delegate set-encoder-code } - encoder construct - ] if ; +TUPLE: encoder stream code ; +M: tuple-class construct-empty ; +M: tuple 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 ; + over encoder? [ >r encoder-stream r> ] when ; : redecode ( stream encoding -- newstream ) - over decoder? [ >r delegate r> ] when ; + over decoder? [ >r decoder-stream r> ] when ; +PRIVATE> : ( stream-in stream-out encoding -- duplex ) tuck reencode >r redecode r> ; 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 +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 ; + [ 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 ; +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 ( stream utf16 -- decoder ) + 2 rot stream-read bom>le/be ; + +M: utf16 ( stream utf16 -- encoder ) + drop bom-le over stream-write utf16le ; + +PRIVATE> From fe9ab0e26ba5a272bf3dbf97aecdcf4e3375eac4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 15 Mar 2008 17:45:05 -0700 Subject: [PATCH 05/28] 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 ; + +: ( x -- imp ) + "test-implementation" (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 ISimple::returnOK ] unit-test +E_FAIL 1array [ 0 ISimple::returnError ] unit-test +1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test + +! Test that the helper functions for QueryInterface, AddRef, Release work + +: ( x -- imp ) + "test-implementation" heap-size malloc (make-test-implementation) ; + +SYMBOL: +guinea-pig-implementation+ + +0 +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 [ 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 53ccdc39542910f2a107f2f4347652e4d94e61b9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 16 Mar 2008 18:36:33 -0700 Subject: [PATCH 06/28] 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 com-interface-definition + +TUPLE: com-function-definition name return parameters ; +C: 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 + ; + +: 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 + + dup save-com-interface-definition + define-words-for-com-interface ; parsing From b362175d436099b4214e88a861eb15e721059d86 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 18 Mar 2008 17:01:14 -0400 Subject: [PATCH 07/28] 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 } +{ $subsection } ; -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 f decoder construct-boa ; ] when nip ; : read-loop ( n stream -- string ) - over 0 [ + 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 : ( encoding -- stream ) @@ -7,7 +7,7 @@ IN: io.streams.byte-array : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* - >byte-array ; inline + dup encoder? [ encoder-stream ] when >byte-array ; inline : ( byte-array encoding -- stream ) >r >byte-vector dup reverse-here r> ; 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 ; + : ( str -- stream ) - >sbuf dup reverse-here f ; + >sbuf dup reverse-here null ; : with-string-reader ( str quot -- ) >r 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 [ 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 ; 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 ( stream utf16 -- decoder ) - 2 rot stream-read bom>le/be ; + drop 2 over stream-read bom>le/be ; M: utf16 ( stream utf16 -- encoder ) drop bom-le over stream-write utf16le ; 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 [ + "launcher-test-1" temp-file binary [ swap >>stdout "echo Hello" >>command @@ -84,7 +84,7 @@ accessors kernel sequences ; "env" >>command { { "A" "B" } } >>environment - latin1 lines + ascii lines "A=B" swap member? ] unit-test @@ -93,5 +93,5 @@ accessors kernel sequences ; "env" >>command { { "A" "B" } } >>environment +replace-environment+ >>environment-mode - latin1 lines + ascii lines ] unit-test From 4b37c9098ef8be2b9471d80d889af7bbe1d61d81 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 16:54:42 +1300 Subject: [PATCH 08/28] 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* ; -: " parse-tokens " " join ebnf>quot call ; parsing +: " parse-multiline-string ebnf>quot call ; parsing From cc9a17b551980b43b016bdc7154bcf7c65d12ccf Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:00:53 +1300 Subject: [PATCH 09/28] 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 ] action ; + [ + CHAR: a CHAR: z range , + "-" token [ first ] action , + ] choice* repeat1 [ >string ] action ; : 'terminal' ( -- parser ) - "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] action ; + [ + "'" token hide , + [ CHAR: ' = not ] satisfy repeat1 , + "'" token hide , + ] seq* [ first >string ] 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 ] action ; + [ + "{" token sp hide , + [ 'choice' sp ] delay , + "}" token sp hide , + ] seq* [ first ] action ; : 'optional' ( -- 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 ; : 'sequence' ( -- parser ) [ @@ -134,8 +147,7 @@ DEFER: 'choice' 'group' sp , 'repeat0' sp , 'optional' sp , - ] { } make choice - repeat1 [ + ] choice* repeat1 [ dup length 1 = [ first ] [ ] 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 ] action ; + [ + "=>" token hide , + [ + [ blank? ] satisfy ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat1 [ >string ] action sp , + ] seq* [ first ] 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 ] action ; + [ + 'non-terminal' [ ebnf-non-terminal-symbol ] action , + "=" token sp hide , + 'rhs' , + ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) 'rule' sp "." token sp hide list-of [ ] action ; From 757853812271dbeb31c97f5d33d2f4bf14f9f55f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:34:28 +1300 Subject: [PATCH 10/28] 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 ] 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 ] action ; : 'terminal' ( -- parser ) - [ - "'" token hide , - [ CHAR: ' = not ] satisfy repeat1 , - "'" token hide , - ] seq* [ first >string ] action ; + #! A terminal is an identifier enclosed in quotations + #! and it represents the literal value of the identifier. + 'identifier' [ ] action ; : 'element' ( -- parser ) [ From 708d55fb8ef4777cb3464b498d794d04a7f96a3a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:37:08 +1300 Subject: [PATCH 11/28] 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 ] action ; : 'optional' ( -- parser ) [ - "[" token sp hide , + "[" syntax , [ 'choice' sp ] delay , - "]" token sp hide , + "]" syntax , ] seq* [ first ] 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 ] action ; : 'ebnf' ( -- parser ) - 'rule' sp "." token sp hide list-of [ ] action ; + 'rule' sp "." syntax list-of [ ] action ; : ebnf>quot ( string -- quot ) 'ebnf' parse [ From 9403d97e22c1e0e59ce4285b033b4db5e4f18b2b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:52:22 +1300 Subject: [PATCH 12/28] 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 ] action ; + "{" [ ] "}" grouped ; : 'optional' ( -- parser ) - [ - "[" syntax , - [ 'choice' sp ] delay , - "]" syntax , - ] seq* [ first ] action ; + "[" [ ] "]" grouped ; : 'sequence' ( -- parser ) [ @@ -174,14 +173,14 @@ DEFER: 'choice' 'group' sp , 'repeat0' sp , 'optional' sp , - ] choice* repeat1 [ + ] choice* repeat1 [ dup length 1 = [ first ] [ ] if - ] action ; + ] action ; : 'choice' ( -- parser ) 'sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if - ] action ; + ] action ; : 'action' ( -- parser ) [ From eef6ae782730ba22a779997023c20d71730abcae Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 18:07:25 +1300 Subject: [PATCH 13/28] 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' [ ] 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' "[" [ ] "]" 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 ] action ; : 'ebnf' ( -- parser ) - 'rule' sp "." syntax list-of [ ] action ; + 'rule' sp repeat1 [ ] action ; : ebnf>quot ( string -- quot ) 'ebnf' parse [ From 208c88c44949f72f62d9cd6ffbf700d301232963 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 18:35:45 +1300 Subject: [PATCH 14/28] 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 ; =' | '>') 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 Date: Tue, 18 Mar 2008 22:56:54 -0700 Subject: [PATCH 15/28] 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 : ( x -- imp ) "test-implementation" (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 ISimple::returnOK ] unit-test -E_FAIL 1array [ 0 ISimple::returnError ] unit-test -1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test - -! Test that the helper functions for QueryInterface, AddRef, Release work - : ( 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 +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 ISimple::returnOK ] unit-test + E_FAIL *long 1array [ 0 ISimple::returnError ] unit-test + 1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test + ! Test that the helper functions for QueryInterface, AddRef, Release work + + 0 +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 [ IUnknown::QueryInterface ] keep *void* ; + f + [ 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: + ( ) + ( ) + ... ; +"> } +{ $description "\nFor the interface " { $snippet "" } ", a word " { $snippet "-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "::" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "" } ". A " { $snippet "" } " 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 com-interface-definition @@ -18,7 +24,9 @@ TUPLE: com-function-definition name return parameters ; C: 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 Date: Tue, 18 Mar 2008 23:02:21 -0700 Subject: [PATCH 16/28] 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 Date: Wed, 19 Mar 2008 19:15:52 +1300 Subject: [PATCH 17/28] 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 C: ebnf-terminal +C: ebnf-any-character +C: ebnf-ensure-not C: ebnf-choice C: ebnf-sequence C: 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 ] action ; @@ -144,6 +156,10 @@ DEFER: 'rhs' #! and it represents the literal value of the identifier. 'identifier' [ ] action ; +: 'any-character' ( -- parser ) + #! A parser to match the symbol for any character match. + [ CHAR: . = ] satisfy [ drop ] 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 ) "[" [ ] "]" 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 ] 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 Date: Wed, 19 Mar 2008 02:43:23 -0500 Subject: [PATCH 18/28] 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 } { $subsection } { $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 Date: Wed, 19 Mar 2008 02:43:36 -0500 Subject: [PATCH 19/28] 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 Date: Thu, 20 Mar 2008 01:18:09 +1300 Subject: [PATCH 20/28] 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 C: ebnf-choice C: ebnf-sequence C: ebnf-repeat0 +C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: 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 ) - "{" [ ] "}" grouped ; + [ ] "*" syntax grouped ; + +: 'repeat1' ( -- parser ) + [ ] "+" syntax grouped ; : 'optional' ( -- parser ) - "[" [ ] "]" grouped ; + [ ] "?" 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 ] [ ] if From c0b7bdf823001f4389e7f13df86d05a16dba0822 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 01:25:57 +1300 Subject: [PATCH 21/28] 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 ] action ; From 65fabeec11956cf7d2d7ddacd50b33b7d6e10823 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 02:16:30 +1300 Subject: [PATCH 22/28] 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 } ; aword EBNF> Now actions can appear anywhere after an element, and can be any factor code between [[ ... ]] delimiters: 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 @@ -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 ] [ ] 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 ] action ; + "]]" token ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat0 [ >string ] action ; + +: 'action' ( -- parser ) + "[[" 'factor-code' "]]" syntax-pack [ ] action ; : 'rhs' ( -- parser ) [ 'choice' , 'action' sp optional , - ] seq* ; + ] seq* repeat1 [ + dup length 1 = [ first ] [ ] if + ] action ; : 'rule' ( -- parser ) [ From 92d8140d87cff4015eb9d396296db0d015d7e0dd Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 03:05:40 +1300 Subject: [PATCH 23/28] 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: --- 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 @@ -34,12 +34,10 @@ C: 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 ) [ ] "?" 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 ] 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 ] [ ] if ] action ; @@ -237,29 +247,12 @@ DEFER: 'choice' 'sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if ] action ; - -: 'factor-code' ( -- parser ) - [ - "]]" token ensure-not , - [ drop t ] satisfy , - ] seq* [ first ] action repeat0 [ >string ] action ; - -: 'action' ( -- parser ) - "[[" 'factor-code' "]]" syntax-pack [ ] action ; - -: 'rhs' ( -- parser ) - [ - 'choice' , - 'action' sp optional , - ] seq* repeat1 [ - dup length 1 = [ first ] [ ] if - ] action ; : 'rule' ( -- parser ) [ 'non-terminal' [ ebnf-non-terminal-symbol ] action , "=" syntax , - 'rhs' , + 'choice' , ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) From 97b58580a7a0bb633d88c1f7855ba3ad7a2cbf03 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 03:30:53 +1300 Subject: [PATCH 24/28] 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 ; + +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 Date: Wed, 19 Mar 2008 13:26:39 -0500 Subject: [PATCH 25/28] 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 Date: Wed, 19 Mar 2008 14:25:53 -0500 Subject: [PATCH 26/28] 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 : ( view rect -- window ) [ 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 + TUPLE: cocoa-ui-backend ; SYMBOL: stop-after-last-window? @@ -47,27 +51,30 @@ M: pasteboard set-clipboard-contents dup rot world>NSRect dup install-window-delegate over -> release - 2array + ] keep set-world-handle ; M: cocoa-ui-backend set-title ( string world -- ) - world-handle second swap -> setTitle: ; + world-handle handle-window swap -> 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 Date: Wed, 19 Mar 2008 14:39:08 -0500 Subject: [PATCH 27/28] 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-files + "kernel" 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 run + "vocabs.loader.test.2" 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 where ] unit-test +[ "kernel" 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 ; -: ( name root -- vocab-link ) - [ dup vocab-root ] unless* vocab-link construct-boa ; +: ( 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 ] if ; - UNION: vocab-spec vocab vocab-link ; +GENERIC: >vocab-link ( name -- vocab ) + +M: vocab-spec >vocab-link ; + +M: string >vocab-link dup vocab [ ] [ ] ?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 : $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 Date: Wed, 19 Mar 2008 15:24:49 -0500 Subject: [PATCH 28/28] 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: ( stream decoding -- newstream ) -GENERIC: ( stream encoding -- newstream ) - : replacement-char HEX: fffd ; -! Decoding - - ( stream encoding -- newstream ) + +TUPLE: encoder stream code ; + +TUPLE: encode-error ; + +: encode-error ( -- * ) \ encode-error construct-empty throw ; + +! Decoding + + construct-empty ; M: tuple 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 construct-empty ; M: tuple encoder construct-boa ; @@ -132,6 +133,7 @@ INSTANCE: encoder plain-writer : redecode ( stream encoding -- newstream ) over decoder? [ >r decoder-stream r> ] when ; + PRIVATE> : ( 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 [