From 308d383ccde48bc88858aba3c923a59c5a3e9817 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Aug 2009 00:10:23 -0500 Subject: [PATCH 1/4] small fix for lexer --- core/lexer/lexer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 036c7d9721..b3bd3cacdb 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -49,7 +49,7 @@ M: lexer skip-word ( lexer -- ) ] change-lexer-column ; : still-parsing? ( lexer -- ? ) - [ line>> ] [ text>> ] bi length <= ; + [ line>> ] [ text>> length ] bi <= ; : still-parsing-line? ( lexer -- ? ) [ column>> ] [ line-length>> ] bi < ; From 761ed6356b42b9f2cbf2fb6e5e20ec8cc75c2837 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Aug 2009 03:44:54 -0500 Subject: [PATCH 2/4] fix HEREDOC:s, add DELIMITED: which is like a HEREDOC: where the terminator can appear anywhere --- basis/multiline/multiline-docs.factor | 30 ++++++++---- basis/multiline/multiline-tests.factor | 66 +++++++++++++++++++------- basis/multiline/multiline.factor | 36 ++++++++++++-- 3 files changed, 101 insertions(+), 31 deletions(-) diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 0977acd1cd..fd91c440d7 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax strings ; IN: multiline HELP: STRING: @@ -19,24 +19,33 @@ HELP: /* } ; HELP: HEREDOC: -{ $syntax "HEREDOC: marker\n...text...marker" } -{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } } -{ $description "A multiline string syntax with a user-specified terminating delimiter. HEREDOC: reads the next word, and uses it as the 'close quote'. All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string. The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word. The delimiting word should be an alphanumeric token. It should not be, as in some other languages, a \"quoted string\"." } +{ $syntax "HEREDOC: marker\n...text...\nmarker" } +{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } } +{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." } +{ $warning "Whitespace is significant." } { $examples { $example "USING: multiline prettyprint ;" - "HEREDOC: END\nx\nEND ." + "HEREDOC: END\nx\nEND\n." "\"x\\n\"" } - { $example "USING: multiline prettyprint ;" - "HEREDOC: END\nxEND ." - "\"x\"" - } { $example "USING: multiline prettyprint sequences ;" - "2 5 HEREDOC: zap\nfoo\nbarzap subseq ." + "2 5 HEREDOC: zap\nfoo\nbar\nzap\nsubseq ." "\"o\\nb\"" } } ; +HELP: DELIMITED: +{ $syntax "DELIMITED: marker\n...text...\nmarker" } +{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } } +{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." } +{ $examples + { $example "USING: multiline prettyprint ;" + "DELIMITED: factor blows my mind" +"whoafactor blows my mind ." + "\"whoa\"" + } +} ; + { POSTPONE: <" POSTPONE: STRING: } related-words HELP: parse-multiline-string @@ -49,6 +58,7 @@ ARTICLE: "multiline" "Multiline" { $subsection POSTPONE: STRING: } { $subsection POSTPONE: <" } { $subsection POSTPONE: HEREDOC: } +{ $subsection POSTPONE: DELIMITED: } "Multiline comments:" { $subsection POSTPONE: /* } "Writing new multiline parsing words:" diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index 2458589d27..25610ed660 100644 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -1,4 +1,4 @@ -USING: multiline tools.test ; +USING: accessors eval multiline tools.test ; IN: multiline.tests STRING: test-it @@ -26,36 +26,66 @@ hi"> ] unit-test [ "foo\nbar\n" ] [ HEREDOC: END foo bar -END ] unit-test - -[ "foo\nbar" ] [ HEREDOC: END -foo -barEND ] unit-test +END +] unit-test [ "" ] [ HEREDOC: END -END ] unit-test +END +] unit-test -[ " " ] [ HEREDOC: END - END ] unit-test +[ " END\n" ] [ HEREDOC: END + END +END +] unit-test [ "\n" ] [ HEREDOC: END -END ] unit-test +END +] unit-test -[ "x" ] [ HEREDOC: END -xEND ] unit-test +[ "x\n" ] [ HEREDOC: END +x +END +] unit-test -[ "xyz " ] [ HEREDOC: END -xyz END ] unit-test +[ "x\n" ] [ HEREDOC: END +x +END +] unit-test + +[ "xyz \n" ] [ HEREDOC: END +xyz +END +] unit-test [ "} ! * # \" «\n" ] [ HEREDOC: END } ! * # " « -END ] unit-test +END +] unit-test -[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X +[ 21 "foo\nbar\n" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X foo -barX HEREDOC: END ! mumble +bar +X +HEREDOC: END HEREDOC: FOO FOO -END 22 ] unit-test +END +22 ] unit-test +[ "lol\n xyz\n" ] +[ +HEREDOC: xyz +lol + xyz +xyz +] unit-test + + +[ "lol" ] +[ DELIMITED: aol +lolaol ] unit-test + +[ "whoa" ] +[ DELIMITED: factor blows my mind +whoafactor blows my mind ] unit-test diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index e4334f1201..4eaafe1f18 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -4,6 +4,8 @@ USING: namespaces make parser lexer kernel sequences words quotations math accessors locals ; IN: multiline +ERROR: bad-heredoc identifier ; + > ; @@ -46,6 +48,28 @@ SYNTAX: STRING: change-column drop ] "" make ; +: rest-of-line ( -- seq ) + lexer get [ line-text>> ] [ column>> ] bi tail ; + +:: advance-same-line ( text -- ) + lexer get [ text length + ] change-column drop ; + +:: (parse-til-line-begins) ( begin-text -- ) + lexer get still-parsing? [ + lexer get line-text>> begin-text sequence= [ + begin-text advance-same-line + ] [ + lexer get line-text>> % "\n" % + lexer get next-line + begin-text (parse-til-line-begins) + ] if + ] [ + begin-text bad-heredoc + ] if ; + +: parse-til-line-begins ( begin-text -- seq ) + [ (parse-til-line-begins) ] "" make ; + PRIVATE> : parse-multiline-string ( end-text -- str ) @@ -66,7 +90,13 @@ SYNTAX: {" SYNTAX: /* "*/" parse-multiline-string drop ; SYNTAX: HEREDOC: - scan + lexer get skip-blank + rest-of-line lexer get next-line - 0 (parse-multiline-string) - parsed ; + parse-til-line-begins parsed ; + +SYNTAX: DELIMITED: + lexer get skip-blank + rest-of-line + lexer get next-line + 0 (parse-multiline-string) parsed ; From 5fe3a6244629388da3c02929d25e16e4787ea8a4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Aug 2009 03:46:46 -0500 Subject: [PATCH 3/4] io.launcher.windows.nt: don't call duplicate-handle, and fix memory leak; io.backend.windows: track win32-handle instances in global win32-handles set to help find leaks --- basis/io/backend/windows/windows.factor | 25 +++++++++++++++----- basis/io/files/windows/windows.factor | 6 ++--- basis/io/launcher/windows/nt/nt-tests.factor | 15 ++++++++++++ basis/io/launcher/windows/nt/nt.factor | 18 +++++++------- basis/io/launcher/windows/nt/test/input.txt | 1 + 5 files changed, 46 insertions(+), 19 deletions(-) create mode 100755 basis/io/launcher/windows/nt/test/input.txt diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 2e9aac2ac9..fde5cf9b12 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -4,23 +4,36 @@ USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.ports io.binary io.timeouts system strings kernel math namespaces sequences windows.errors windows.kernel32 windows.shell32 windows.types windows.winsock -splitting continuations math.bitwise accessors ; +splitting continuations math.bitwise accessors init sets assocs ; IN: io.backend.windows +: win32-handles ( -- assoc ) + \ win32-handles [ H{ } clone ] initialize-alien ; + +TUPLE: win32-handle < identity-tuple handle disposed ; + +M: win32-handle hashcode* handle>> hashcode* ; + : set-inherit ( handle ? -- ) - [ HANDLE_FLAG_INHERIT ] dip + [ handle>> HANDLE_FLAG_INHERIT ] dip >BOOLEAN SetHandleInformation win32-error=0/f ; -TUPLE: win32-handle handle disposed ; - : new-win32-handle ( handle class -- win32-handle ) - new swap [ >>handle ] [ f set-inherit ] bi ; + new swap >>handle + dup f set-inherit + dup win32-handles conjoin ; : ( handle -- win32-handle ) win32-handle new-win32-handle ; +ERROR: disposing-twice ; + +: unregister-handle ( handle -- ) + win32-handles delete-at* + [ t >>disposed drop ] [ disposing-twice ] if ; + M: win32-handle dispose* ( handle -- ) - handle>> CloseHandle drop ; + [ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ; TUPLE: win32-file < win32-handle ptr ; diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 444ba98c7d..43463bd3f1 100755 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -47,10 +47,8 @@ IN: io.files.windows GetLastError ERROR_ALREADY_EXISTS = not ; : set-file-pointer ( handle length method -- ) - [ dupd d>w/w ] dip SetFilePointer - INVALID_SET_FILE_POINTER = [ - CloseHandle "SetFilePointer failed" throw - ] when drop ; + [ [ handle>> ] dip d>w/w ] dip SetFilePointer + INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ; HOOK: open-append os ( path -- win32-file ) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 4587556e0c..f57f7b6d47 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -164,4 +164,19 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test +[ "( scratchpad ) " ] [ + console-vm "-run=listener" 2array + ascii [ "USE: system 0 exit" print flush readln ] with-process-stream +] unit-test +[ ] [ + console-vm "-run=listener" 2array + ascii [ "USE: system 0 exit" print ] with-process-writer +] unit-test + +[ ] [ + + console-vm "-run=listener" 2array >>command + "vocab:io/launcher/windows/nt/test/input.txt" >>stdin + try-process +] unit-test diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor index 5ebb38abc2..e62373cbd7 100755 --- a/basis/io/launcher/windows/nt/nt.factor +++ b/basis/io/launcher/windows/nt/nt.factor @@ -10,21 +10,21 @@ IN: io.launcher.windows.nt : duplicate-handle ( handle -- handle' ) GetCurrentProcess ! source process - swap ! handle + swap handle>> ! handle GetCurrentProcess ! target process f [ ! target handle DUPLICATE_SAME_ACCESS ! desired access TRUE ! inherit handle - DUPLICATE_CLOSE_SOURCE ! options + 0 ! options DuplicateHandle win32-error=0/f - ] keep *void* ; + ] keep *void* &dispose ; ! /dev/null simulation : null-input ( -- pipe ) - (pipe) [ in>> handle>> ] [ out>> dispose ] bi ; + (pipe) [ in>> &dispose ] [ out>> dispose ] bi ; : null-output ( -- pipe ) - (pipe) [ in>> dispose ] [ out>> handle>> ] bi ; + (pipe) [ in>> dispose ] [ out>> &dispose ] bi ; : null-pipe ( mode -- pipe ) { @@ -49,7 +49,7 @@ IN: io.launcher.windows.nt create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? &dispose handle>> ; + CreateFile dup invalid-handle? &dispose ; : redirect-append ( path access-mode create-mode -- handle ) [ path>> ] 2dip @@ -58,10 +58,10 @@ IN: io.launcher.windows.nt dup 0 FILE_END set-file-pointer ; : redirect-handle ( handle access-mode create-mode -- handle ) - 2drop handle>> duplicate-handle ; + 2drop ; : redirect-stream ( stream access-mode create-mode -- handle ) - [ underlying-handle handle>> ] 2dip redirect-handle ; + [ underlying-handle ] 2dip redirect-handle ; : redirect ( obj access-mode create-mode -- handle ) { @@ -72,7 +72,7 @@ IN: io.launcher.windows.nt { [ pick win32-file? ] [ redirect-handle ] } [ redirect-stream ] } cond - dup [ dup t set-inherit ] when ; + dup [ dup t set-inherit handle>> ] when ; : redirect-stdout ( process args -- handle ) drop diff --git a/basis/io/launcher/windows/nt/test/input.txt b/basis/io/launcher/windows/nt/test/input.txt new file mode 100755 index 0000000000..99c3cc6fb1 --- /dev/null +++ b/basis/io/launcher/windows/nt/test/input.txt @@ -0,0 +1 @@ +USE: system 0 exit From 507e2b7f3a962dbca7633b5bc715f83551de3d39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Aug 2009 03:49:05 -0500 Subject: [PATCH 4/4] Fix some unit test failures --- basis/compiler/tests/redefine3.factor | 4 ++-- basis/compiler/tests/stack-trace.factor | 4 ++-- core/slots/slots-tests.factor | 17 ----------------- 3 files changed, 4 insertions(+), 21 deletions(-) diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 38842696d7..67added49d 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -5,11 +5,11 @@ IN: compiler.tests.redefine3 GENERIC: sheeple ( obj -- x ) -M: object sheeple drop "sheeple" ; +M: object sheeple drop "sheeple" ; inline MIXIN: empty-mixin -M: empty-mixin sheeple drop "wake up" ; +M: empty-mixin sheeple drop "wake up" ; inline : sheeple-test ( -- string ) { } sheeple ; diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index a160272b21..20a5cc867c 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -13,7 +13,7 @@ IN: compiler.tests.stack-trace [ baz ] [ 3 = ] must-fail-with [ t ] [ symbolic-stack-trace - [ word? ] filter + 2 head* { baz bar foo } tail? ] unit-test @@ -24,7 +24,7 @@ IN: compiler.tests.stack-trace [ t ] [ [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any? ] unit-test - + [ t f ] [ [ { "hi" } bleh ] ignore-errors \ + stack-trace-any? diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 81251d728f..d22ca31d00 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -18,23 +18,6 @@ TUPLE: hello length ; [ "xyz" 4 >>length ] [ no-method? ] must-fail-with -[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test - -[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test - -! See if declarations are cleared on redefinition -[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test - -[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test - -[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test - -[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test - ! Test protocol slots SLOT: my-protocol-slot-test