From 1ee12b512cf3e4149f52a8f454fc755e827591de Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 1 Feb 2008 16:04:41 -0600 Subject: [PATCH 01/11] builder: minor tweaks --- extra/builder/builder.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a2b5dffb4d..4c770ff4ce 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -31,8 +31,6 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ; - : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -61,7 +59,7 @@ if "factor" cd -{ "/usr/bin/git" "show" } +{ "git" "show" } [ readln ] with-stream " " split second "../git-id" [ print ] with-stream @@ -76,7 +74,7 @@ if "builder: vm compile" throw ] if -"wget http://factorcode.org/images/latest/" boot-image append system +"wget http://factorcode.org/images/latest/" boot-image-name append system 0 = [ ] [ @@ -84,7 +82,11 @@ if "builder: image download" throw ] if -[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ] +[ + "./factor -i=" boot-image-name " -no-user-init > ../boot-log" + 3append + system +] benchmark nip "../boot-time" [ . ] with-stream 0 = From a849bc3097ef5bc7942a0a7b74332274a95c072b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 1 Feb 2008 16:10:18 -0600 Subject: [PATCH 02/11] builder: fix using --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 4c770ff4ce..a9a4c159f8 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,5 +1,5 @@ -USING: kernel io io.files io.launcher +USING: kernel io io.files io.launcher tools.deploy.backend system namespaces sequences splitting math.parser unix prettyprint tools.time calendar bake vars ; From cef80543ad7504c0c77fdf8b04ab050e92ff0fba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 16:26:11 -0600 Subject: [PATCH 03/11] Fix set-string-nth GC issue --- vm/types.c | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/vm/types.c b/vm/types.c index f34f5e57ca..1f0287b1f0 100755 --- a/vm/types.c +++ b/vm/types.c @@ -431,23 +431,30 @@ CELL string_nth(F_STRING* string, CELL index) } } +/* allocates memory */ void set_string_nth(F_STRING* string, CELL index, CELL value) { bput(SREF(string,index),value & 0xff); + F_BYTE_ARRAY *aux; + if(string->aux == F) { if(value <= 0xff) return; else { - string->aux = tag_object(allot_byte_array( + REGISTER_UNTAGGED(string); + aux = allot_byte_array( untag_fixnum_fast(string->length) - * sizeof(u16))); + * sizeof(u16)); + UNREGISTER_UNTAGGED(string); + string->aux = tag_object(aux); } } + else + aux = untag_object(string->aux); - F_BYTE_ARRAY *aux = untag_object(string->aux); cput(BREF(aux,index * sizeof(u16)),value >> 8); } @@ -463,10 +470,13 @@ F_STRING* allot_string_internal(CELL capacity) string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; + set_string_nth(string,capacity,0); + return string; } +/* allocates memory */ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) @@ -476,7 +486,11 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) CELL i; for(i = start; i < capacity; i++) + { + REGISTER_UNTAGGED(string); set_string_nth(string,i,fill); + UNREGISTER_UNTAGGED(string); + } } } @@ -484,7 +498,9 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) F_STRING *allot_string(CELL capacity, CELL fill) { F_STRING* string = allot_string_internal(capacity); + REGISTER_UNTAGGED(string); fill_string(string,0,capacity,fill); + UNREGISTER_UNTAGGED(string); return string; } @@ -506,7 +522,10 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) UNREGISTER_UNTAGGED(string); memcpy(new_string + 1,string + 1,to_copy); + + REGISTER_UNTAGGED(string); fill_string(new_string,to_copy,capacity,fill); + UNREGISTER_UNTAGGED(string); return new_string; } @@ -529,7 +548,9 @@ DEFINE_PRIMITIVE(resize_string) CELL i; \ for(i = 0; i < length; i++) \ { \ + REGISTER_UNTAGGED(s); \ set_string_nth(s,i,(utype)*string); \ + UNREGISTER_UNTAGGED(s); \ string++; \ } \ return s; \ @@ -552,6 +573,7 @@ DEFINE_PRIMITIVE(resize_string) MEMORY_TO_STRING(char,u8) MEMORY_TO_STRING(u16,u16) +// MEMORY_TO_STRING(u32,u32) bool check_string(F_STRING *s, CELL max) { From f710d192f7e14ab4037ad35ef0269d95534bf627 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 17:13:57 -0600 Subject: [PATCH 04/11] Fix inaccurate notifications in io.monitor on Windows --- extra/io/monitor/monitor-docs.factor | 33 ++++++++++------------ extra/io/monitor/monitor.factor | 9 +++--- extra/io/windows/launcher/launcher.factor | 11 ++++++-- extra/io/windows/nt/monitor/monitor.factor | 32 ++++++++------------- extra/windows/kernel32/kernel32.factor | 6 ++++ 5 files changed, 46 insertions(+), 45 deletions(-) diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitor/monitor-docs.factor index 56fd203bde..de649f48e7 100755 --- a/extra/io/monitor/monitor-docs.factor +++ b/extra/io/monitor/monitor-docs.factor @@ -8,35 +8,32 @@ $nl "Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; HELP: next-change -{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ; +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } { $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; -HELP: +change-file+ -{ $description "Indicates that the contents of the file have changed." } ; +HELP: +add-file+ +{ $description "Indicates that the file has been added to the directory." } ; -HELP: +change-name+ -{ $description "Indicates that the file name has changed." } ; +HELP: +remove-file+ +{ $description "Indicates that the file has been removed from the directory." } ; -HELP: +change-size+ -{ $description "Indicates that the file size has changed." } ; +HELP: +modify-file+ +{ $description "Indicates that the file contents have changed." } ; -HELP: +change-attributes+ -{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ; - -HELP: +change-modified+ -{ $description "Indicates that the last modification time of the file has changed." } ; +HELP: +rename-file+ +{ $description "Indicates that file has been renamed." } ; ARTICLE: "io.monitor.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" -{ $subsection +change-file+ } -{ $subsection +change-name+ } -{ $subsection +change-size+ } -{ $subsection +change-attributes+ } -{ $subsection +change-modified+ } ; +{ $subsection +add-file+ } +{ $subsection +remove-file+ } +{ $subsection +modify-file+ } +{ $subsection +rename-file+ } +{ $subsection +add-file+ } ; ARTICLE: "io.monitor" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 044fa9572b..4dc5081513 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -7,11 +7,10 @@ HOOK: io-backend ( path recursive? -- monitor ) HOOK: next-change io-backend ( monitor -- path changes ) -SYMBOL: +change-file+ -SYMBOL: +change-name+ -SYMBOL: +change-size+ -SYMBOL: +change-attributes+ -SYMBOL: +change-modified+ +SYMBOL: +add-file+ +SYMBOL: +remove-file+ +SYMBOL: +modify-file+ +SYMBOL: +rename-file+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 8f1d1c6756..ec53d9152c 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -119,8 +119,15 @@ TUPLE: CreateProcess-args drop STD_ERROR_HANDLE GetStdHandle ; : redirect-stderr ( args -- handle ) - +stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed ; + +stderr+ get + dup +stdout+ eq? [ + drop + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stderr ?closed + ] if ; : inherited-stdin ( args -- handle ) CreateProcess-args-stdin-pipe diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index a7c065b878..8e0e63923d 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -4,7 +4,7 @@ USING: alien.c-types destructors io.windows io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitor io.nonblocking io.buffers io.files io sequences -hashtables sorting arrays ; +hashtables sorting arrays combinators ; IN: io.windows.nt.monitor TUPLE: monitor path recursive? queue closed? ; @@ -53,25 +53,17 @@ M: windows-nt-io ( path recursive? -- monitor ) ] with-port-timeout ] with-destructors ; -: parse-action-flag ( action mask symbol -- action ) - >r over bitand 0 > [ r> , ] [ r> drop ] if ; +: parse-action ( action -- changed ) + { + { [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] } + { [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] } + { [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] } + { [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] } + { [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] } + { [ t ] [ +modify-file+ ] } + } cond nip ; -: parse-action ( action -- changes ) - [ - FILE_NOTIFY_CHANGE_FILE +change-file+ parse-action-flag - FILE_NOTIFY_CHANGE_DIR_NAME +change-name+ parse-action-flag - FILE_NOTIFY_CHANGE_ATTRIBUTES +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_SIZE +change-size+ parse-action-flag - FILE_NOTIFY_CHANGE_LAST_WRITE +change-modified+ parse-action-flag - FILE_NOTIFY_CHANGE_LAST_ACCESS +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_EA +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_CREATION +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_SECURITY +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_FILE_NAME +change-name+ parse-action-flag - drop - ] { } make ; - -: changed-file ( directory buffer -- changes path ) +: changed-file ( directory buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength @@ -79,7 +71,7 @@ M: windows-nt-io ( path recursive? -- monitor ) } get-slots >r memory>u16-string path+ r> parse-action swap ; : (changed-files) ( directory buffer -- ) - 2dup changed-file namespace [ append ] change-at + 2dup changed-file namespace [ swap add ] change-at dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? [ 3drop ] [ swap (changed-files) ] if ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 15bdcd3e37..77c7666bfd 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -83,6 +83,12 @@ IN: windows.kernel32 : FILE_NOTIFY_CHANGE_FILE_NAME HEX: 200 ; inline : FILE_NOTIFY_CHANGE_ALL HEX: 3ff ; inline +: FILE_ACTION_ADDED 1 ; inline +: FILE_ACTION_REMOVED 2 ; inline +: FILE_ACTION_MODIFIED 3 ; inline +: FILE_ACTION_RENAMED_OLD_NAME 4 ; inline +: FILE_ACTION_RENAMED_NEW_NAME 5 ; inline + C-STRUCT: FILE_NOTIFY_INFORMATION { "DWORD" "NextEntryOffset" } { "DWORD" "Action" } From 3917a9472a4f8ee66f145e1de5c60cc3e45919d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 17:14:10 -0600 Subject: [PATCH 05/11] Implement default_vm_path() on netbsd --- vm/os-netbsd.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) mode change 100644 => 100755 vm/os-netbsd.c diff --git a/vm/os-netbsd.c b/vm/os-netbsd.c old mode 100644 new mode 100755 index b9238b7877..c33b4ad69c --- a/vm/os-netbsd.c +++ b/vm/os-netbsd.c @@ -1,6 +1,11 @@ #include "master.h" +extern int main(); + const char *vm_executable_path(void) { - return NULL; + static Dl_info info = {0}; + if (!info.dli_fname) + dladdr(main, &info); + return info.dli_fname; } From 4b7034384c10f437090775b44a3b40bcb7f036af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 17:48:29 -0600 Subject: [PATCH 06/11] Eliminate core ascii dependency --- core/parser/parser.factor | 15 +++++++------- core/prettyprint/backend/backend.factor | 25 +++++++++--------------- {core => extra}/ascii/ascii-docs.factor | 0 {core => extra}/ascii/ascii-tests.factor | 0 {core => extra}/ascii/ascii.factor | 2 -- {core => extra}/ascii/authors.txt | 0 {core => extra}/ascii/summary.txt | 0 {core => extra}/ascii/tags.txt | 0 8 files changed, 16 insertions(+), 26 deletions(-) rename {core => extra}/ascii/ascii-docs.factor (100%) rename {core => extra}/ascii/ascii-tests.factor (100%) rename {core => extra}/ascii/ascii.factor (96%) rename {core => extra}/ascii/authors.txt (100%) rename {core => extra}/ascii/summary.txt (100%) rename {core => extra}/ascii/tags.txt (100%) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 862b266d05..8b6ea57833 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string io.streams.lines vocabs -source-files classes hashtables compiler.errors compiler.units -ascii ; +source-files classes hashtables compiler.errors compiler.units ; IN: parser TUPLE: lexer text line column ; @@ -55,8 +54,9 @@ t parser-notes set-global 0 over set-lexer-column dup lexer-line 1+ swap set-lexer-line ; -: skip ( i seq quot -- n ) - over >r find* drop +: skip ( i seq ? -- n ) + over >r + [ swap CHAR: \s eq? xor ] curry find* drop [ r> drop ] [ r> length ] if* ; inline : change-column ( lexer quot -- ) @@ -67,14 +67,13 @@ t parser-notes set-global GENERIC: skip-blank ( lexer -- ) M: lexer skip-blank ( lexer -- ) - [ [ blank? not ] skip ] change-column ; + [ t skip ] change-column ; GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = - [ drop 1+ ] [ [ blank? ] skip ] if + 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index a5d0cee6c5..e64295cc0c 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors generic hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects -tuples classes float-arrays float-vectors ascii ; +tuples classes float-arrays float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -58,24 +58,17 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ - { CHAR: \e "\\e" } - { CHAR: \n "\\n" } - { CHAR: \r "\\r" } - { CHAR: \t "\\t" } - { CHAR: \0 "\\0" } - { CHAR: \\ "\\\\" } - { CHAR: \" "\\\"" } + { CHAR: \e CHAR: \\e } + { CHAR: \n CHAR: \\n } + { CHAR: \r CHAR: \\r } + { CHAR: \t CHAR: \\t } + { CHAR: \0 CHAR: \\0 } + { CHAR: \\ CHAR: \\\\ } + { CHAR: \" CHAR: \\\" } } at ; -: ch>unicode-escape ( ch -- str ) - >hex 6 CHAR: 0 pad-left "\\u" swap append ; - : unparse-ch ( ch -- ) - dup quotable? [ - , - ] [ - dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if % - ] if ; + dup ch>ascii-escape [ ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) string-limit get [ diff --git a/core/ascii/ascii-docs.factor b/extra/ascii/ascii-docs.factor similarity index 100% rename from core/ascii/ascii-docs.factor rename to extra/ascii/ascii-docs.factor diff --git a/core/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor similarity index 100% rename from core/ascii/ascii-tests.factor rename to extra/ascii/ascii-tests.factor diff --git a/core/ascii/ascii.factor b/extra/ascii/ascii.factor similarity index 96% rename from core/ascii/ascii.factor rename to extra/ascii/ascii.factor index 019db5f3b2..e4a365cd1b 100755 --- a/core/ascii/ascii.factor +++ b/extra/ascii/ascii.factor @@ -24,5 +24,3 @@ IN: ascii : alpha? ( ch -- ? ) dup Letter? [ drop t ] [ digit? ] if ; inline - - diff --git a/core/ascii/authors.txt b/extra/ascii/authors.txt similarity index 100% rename from core/ascii/authors.txt rename to extra/ascii/authors.txt diff --git a/core/ascii/summary.txt b/extra/ascii/summary.txt similarity index 100% rename from core/ascii/summary.txt rename to extra/ascii/summary.txt diff --git a/core/ascii/tags.txt b/extra/ascii/tags.txt similarity index 100% rename from core/ascii/tags.txt rename to extra/ascii/tags.txt From bff385269c6eb9ce50f2188cf8ecc424b37a3346 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 1 Feb 2008 18:26:32 -0600 Subject: [PATCH 07/11] Lot's of USING: fixes for ascii or unicode --- core/parser/parser.factor | 76 ++++++++++--------- .../benchmark/knucleotide/knucleotide.factor | 2 +- .../reverse-complement.factor | 2 +- extra/cryptlib/cryptlib.factor | 2 +- extra/fjsc/fjsc.factor | 2 +- extra/globs/globs.factor | 2 +- extra/hexdump/hexdump.factor | 4 +- extra/id3/id3.factor | 2 +- extra/irc/irc.factor | 2 +- extra/json/reader/reader.factor | 2 +- extra/lint/lint.factor | 5 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/peg/ebnf/ebnf.factor | 3 +- extra/peg/peg.factor | 3 +- extra/project-euler/017/017.factor | 3 +- extra/project-euler/022/022.factor | 2 +- extra/prolog/prolog.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/roman/roman.factor | 2 +- extra/rot13/rot13.factor | 2 +- extra/sequences/lib/lib.factor | 4 +- extra/state-parser/state-parser.factor | 2 +- extra/strings/lib/lib.factor | 16 ++-- extra/xml/tokenize/tokenize.factor | 2 +- extra/xml/xml.factor | 2 +- extra/xmode/keyword-map/keyword-map.factor | 3 +- extra/xmode/marker/marker.factor | 2 +- extra/xmode/rules/rules.factor | 2 +- 28 files changed, 81 insertions(+), 74 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 862b266d05..6825029a8e 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -348,45 +348,49 @@ SYMBOL: bootstrap-syntax call ] with-scope ; inline +SYMBOL: interactive-vocabs + +{ + "arrays" + "assocs" + "combinators" + "compiler.errors" + "continuations" + "debugger" + "definitions" + "editors" + "generic" + "help" + "inspector" + "io" + "io.files" + "kernel" + "listener" + "math" + "memory" + "namespaces" + "prettyprint" + "sequences" + "slicing" + "sorting" + "strings" + "syntax" + "tools.annotations" + "tools.crossref" + "tools.memory" + "tools.profiler" + "tools.test" + "tools.time" + "vocabs" + "vocabs.loader" + "words" + "scratchpad" +} interactive-vocabs set-global + : with-interactive-vocabs ( quot -- ) [ "scratchpad" in set - { - "arrays" - "assocs" - "combinators" - "compiler.errors" - "continuations" - "debugger" - "definitions" - "editors" - "generic" - "help" - "inspector" - "io" - "io.files" - "kernel" - "listener" - "math" - "memory" - "namespaces" - "prettyprint" - "sequences" - "slicing" - "sorting" - "strings" - "syntax" - "tools.annotations" - "tools.crossref" - "tools.memory" - "tools.profiler" - "tools.test" - "tools.time" - "vocabs" - "vocabs.loader" - "words" - "scratchpad" - } set-use + interactive-vocabs get set-use call ] with-scope ; inline diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index f036a644ae..ad1ffc1c50 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,6 +1,6 @@ USING: kernel io io.files splitting strings hashtables sequences assocs math namespaces prettyprint - math.parser combinators arrays sorting ; + math.parser combinators arrays sorting unicode.case ; IN: benchmark.knucleotide diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 332489abed..7b09b586f4 100644 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints ; +hints unicode.case ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) diff --git a/extra/cryptlib/cryptlib.factor b/extra/cryptlib/cryptlib.factor index 65d2ffe48f..2ba81ef15a 100644 --- a/extra/cryptlib/cryptlib.factor +++ b/extra/cryptlib/cryptlib.factor @@ -6,7 +6,7 @@ ! Adapted from cryptlib.h ! Tested with cryptlib 3.3.1.0 USING: cryptlib.libcl kernel hashtables alien math -namespaces sequences assocs libc alien.c-types continuations ; +namespaces sequences assocs libc alien.c-types alien.accessors continuations ; IN: cryptlib diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index fdeed339d8..6beb48e05e 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ; + io.streams.string assocs memoize ascii ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 901191b51e..7204693016 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators regexp lazy-lists sequences kernel -promises strings ; +promises strings unicode.case ; IN: globs digit ( c -- i ) 48 - ; +! : char>digit ( c -- i ) 48 - ; -: string>digits ( s -- seq ) [ char>digit ] { } map-as ; +! : string>digits ( s -- seq ) [ char>digit ] { } map-as ; -: >Upper ( str -- str ) - dup empty? [ - unclip ch>upper 1string swap append - ] unless ; +! : >Upper ( str -- str ) +! dup empty? [ +! unclip ch>upper 1string swap append +! ] unless ; -: >Upper-dashes ( str -- str ) - "-" split [ >Upper ] map "-" join ; +! : >Upper-dashes ( str -- str ) +! "-" split [ >Upper ] map "-" join ; diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index 85a473f503..d99c306b2b 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml.errors xml.data xml.utilities xml.char-classes xml.entities kernel state-parser kernel namespaces strings math -math.parser sequences assocs arrays splitting combinators ; +math.parser sequences assocs arrays splitting combinators unicode.case ; IN: xml.tokenize ! XML namespace processing: ns = namespace diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 826b16b213..65a8e28dea 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs ; +xml.utilities state-parser assocs unicode.categories ; IN: xml ! -- Overall parser with data tree diff --git a/extra/xmode/keyword-map/keyword-map.factor b/extra/xmode/keyword-map/keyword-map.factor index 350d8572a0..4e97e597b2 100644 --- a/extra/xmode/keyword-map/keyword-map.factor +++ b/extra/xmode/keyword-map/keyword-map.factor @@ -1,4 +1,5 @@ -USING: kernel strings assocs sequences hashtables sorting ; +USING: kernel strings assocs sequences hashtables sorting + unicode.case unicode.categories ; IN: xmode.keyword-map ! Based on org.gjt.sp.jedit.syntax.KeywordMap diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index b8331fe6b6..91ccd43907 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -2,7 +2,7 @@ IN: xmode.marker USING: kernel namespaces xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators combinators.lib -strings regexp splitting parser-combinators ; +strings regexp splitting parser-combinators ascii unicode.case ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index acc6308c6f..28237a7b2c 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -1,5 +1,5 @@ USING: xmode.tokens xmode.keyword-map kernel -sequences vectors assocs strings memoize regexp ; +sequences vectors assocs strings memoize regexp unicode.case ; IN: xmode.rules TUPLE: string-matcher string ignore-case? ; From 9f1bcc5d224c80c66315ddd4989eeec8ccb19914 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 18:36:13 -0600 Subject: [PATCH 08/11] Fix resize-string --- core/strings/strings-tests.factor | 5 +++++ vm/data_gc.c | 3 ++- vm/types.c | 26 ++++++++++++++++++++++++-- vm/types.h | 4 ++-- 4 files changed, 33 insertions(+), 5 deletions(-) diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 5ab7f1dffe..459ec7b153 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -51,6 +51,9 @@ unit-test [ "ab" ] [ 2 "abc" resize-string ] unit-test [ "abc\0\0\0" ] [ 6 "abc" resize-string ] unit-test +[ "\u001234b" ] [ 2 "\u001234bc" resize-string ] unit-test +[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test + ! Random tester found this [ { "kernel-error" 3 12 -7 } ] [ [ 2 -7 resize-string ] catch ] unit-test @@ -88,3 +91,5 @@ unit-test "\udeadbe" clone CHAR: \u123456 over clone set-first ] unit-test + + diff --git a/vm/data_gc.c b/vm/data_gc.c index 3ca41d602c..601a677920 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -505,7 +505,6 @@ CELL binary_payload_start(CELL pointer) switch(untag_header(get(pointer))) { /* these objects do not refer to other objects at all */ - case STRING_TYPE: case FLOAT_TYPE: case BYTE_ARRAY_TYPE: case BIT_ARRAY_TYPE: @@ -522,6 +521,8 @@ CELL binary_payload_start(CELL pointer) return CELLS * 2; case QUOTATION_TYPE: return sizeof(F_QUOTATION) - CELLS * 2; + case STRING_TYPE: + return sizeof(F_STRING); /* everything else consists entirely of pointers */ default: return unaligned_object_size(pointer); diff --git a/vm/types.c b/vm/types.c index 1f0287b1f0..24b5e7ff07 100755 --- a/vm/types.c +++ b/vm/types.c @@ -480,7 +480,16 @@ F_STRING* allot_string_internal(CELL capacity) void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) - memset((void*)SREF(string,start),'\0',capacity - start); + { + memset((void *)SREF(string,start),'\0',capacity - start); + + if(string->aux != F) + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + memset((void *)BREF(aux,start * sizeof(u16)),'\0', + (capacity - start) * sizeof(u16)); + } + } else { CELL i; @@ -523,6 +532,19 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) memcpy(new_string + 1,string + 1,to_copy); + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + new_string->aux = tag_object(new_aux); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + F_BYTE_ARRAY *aux = untag_object(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + REGISTER_UNTAGGED(string); fill_string(new_string,to_copy,capacity,fill); UNREGISTER_UNTAGGED(string); @@ -573,7 +595,7 @@ DEFINE_PRIMITIVE(resize_string) MEMORY_TO_STRING(char,u8) MEMORY_TO_STRING(u16,u16) -// MEMORY_TO_STRING(u32,u32) +MEMORY_TO_STRING(u32,u32) bool check_string(F_STRING *s, CELL max) { diff --git a/vm/types.h b/vm/types.h index 6f4234af34..e5003ea069 100755 --- a/vm/types.h +++ b/vm/types.h @@ -83,8 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array) return array->capacity >> TAG_BITS; } -#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index) -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index) +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) INLINE F_STRING* untag_string(CELL tagged) { From 6851b16b3932a0ee057e0423c3a587279726a082 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 18:36:20 -0600 Subject: [PATCH 09/11] Remove dan's make* --- extra/unicode/case/case.factor | 15 ++++++++------- extra/unicode/normalize/normalize.factor | 11 ----------- 2 files changed, 8 insertions(+), 18 deletions(-) diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index 96ae9a790b..ee9e2a0381 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -1,5 +1,6 @@ -USING: kernel unicode.data sequences sequences.next namespaces assocs.lib -unicode.normalize math unicode.categories combinators assocs ; +USING: kernel unicode.data sequences sequences.next namespaces +assocs.lib unicode.normalize math unicode.categories combinators +assocs ; IN: unicode.case : ch>lower ( ch -- lower ) simple-lower at-default ; @@ -20,7 +21,7 @@ SYMBOL: locale ! Just casing locale, or overall? [ swap dot-over = over "ij" member? and swap , ] if ; : lithuanian>upper ( string -- lower ) - [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make* ; + [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ; : mark-above? ( ch -- ? ) combining-class 230 = ; @@ -32,14 +33,14 @@ SYMBOL: locale ! Just casing locale, or overall? dup , "IJ" member? swap mark-above? and [ dot-over , ] when ; : lithuanian>lower ( string -- lower ) - [ [ lithuanian-ch>lower ] each-next ] "" make* ; + [ [ lithuanian-ch>lower ] each-next ] "" make ; : turk-ch>upper ( ch -- ) dup CHAR: i = [ drop CHAR: I , dot-over , ] [ , ] if ; : turk>upper ( string -- upper-i ) - [ [ turk-ch>upper ] each ] "" make* ; + [ [ turk-ch>upper ] each ] "" make ; : turk-ch>lower ( ? next ch -- ? ) { @@ -52,7 +53,7 @@ SYMBOL: locale ! Just casing locale, or overall? } cond ; : turk>lower ( string -- lower-i ) - [ f swap [ turk-ch>lower ] each-next drop ] "" make* ; + [ f swap [ turk-ch>lower ] each-next drop ] "" make ; : word-boundary ( prev char -- new ? ) dup non-starter? [ drop dup ] when @@ -76,7 +77,7 @@ SYMBOL: locale ! Just casing locale, or overall? [ -rot nip call , ] ?if ] 2keep ] each 2drop - ] "" make* ; inline + ] "" make ; inline : >lower ( string -- lower ) i-dot? [ turk>lower ] when diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index b018d115f8..47637e8330 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -2,17 +2,6 @@ USING: sequences namespaces unicode.data kernel combinators.lib math arrays ; IN: unicode.normalize -! Utility word--probably unnecessary -: make* ( seq quot exemplar -- newseq ) - ! quot has access to original seq on stack - ! this just makes the new-resizable the same length as seq - [ - [ - pick length swap new-resizable - [ building set call ] keep - ] keep like - ] with-scope ; inline - ! Conjoining Jamo behavior : hangul-base HEX: ac00 ; inline From 2d381ed84e2845a1174480bcc79eb54ebf02a3d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 22:47:01 -0600 Subject: [PATCH 10/11] Fix http server --- extra/http/server/templating/templating.factor | 2 +- extra/io/server/server.factor | 6 +++--- extra/webapps/cgi/cgi.factor | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 69f8b4e7fd..f5de4664a1 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -25,7 +25,7 @@ M: template-lexer skip-word { { [ 2dup nth CHAR: " = ] [ drop 1+ ] } { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } - { [ t ] [ [ blank? ] skip ] } + { [ t ] [ f skip ] } } cond ] change-column ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6e7cd5a940..408fd29714 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -29,7 +29,7 @@ SYMBOL: log-stream : with-log-file ( file quot -- ) >r r> - [ with-log-stream ] with-disposal ; inline + [ with-log-stream ] curry with-disposal ; inline : with-log-stdio ( quot -- ) stdio get swap with-log-stream ; @@ -47,11 +47,11 @@ SYMBOL: log-stream dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline -: accept-loop ( server quot -- server quot ) +: accept-loop ( server quot -- ) [ swap accept with-client ] 2keep accept-loop ; inline : server-loop ( server quot -- ) - [ accept-loop ] compose with-disposal ; inline + [ accept-loop ] curry with-disposal ; inline : spawn-server ( addrspec quot -- ) "Waiting for connections on " pick unparse append diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 9dd9dca39c..967036a797 100644 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files combinators arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser ; +sequences strings math.parser unicode.case ; IN: webapps.cgi SYMBOL: cgi-root @@ -31,7 +31,7 @@ SYMBOL: cgi-root "method" get >upper "REQUEST_METHOD" set "raw-query" get "QUERY_STRING" set - "Cookie" header-param "HTTP_COOKIE" set + "Cookie" header-param "HTTP_COOKIE" set "User-Agent" header-param "HTTP_USER_AGENT" set "Accept" header-param "HTTP_ACCEPT" set From 68b3d8e1d96800a47d2a78ffaa16d565e27e7ba6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 23:07:19 -0600 Subject: [PATCH 11/11] Tabs are banned --- core/bootstrap/primitives.factor | 14 +++++++------- core/prettyprint/backend/backend.factor | 16 ++++++++-------- core/strings/strings.factor | 2 +- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index fef93e163f..545d904c9c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -15,12 +15,12 @@ crossref off "resource:core/bootstrap/syntax.factor" parse-file "resource:core/cpu/" architecture get { - { "x86.32" "x86/32" } - { "x86.64" "x86/64" } - { "linux-ppc" "ppc/linux" } - { "macosx-ppc" "ppc/macosx" } - { "arm" "arm" } - } at "/bootstrap.factor" 3append parse-file + { "x86.32" "x86/32" } + { "x86.64" "x86/64" } + { "linux-ppc" "ppc/linux" } + { "macosx-ppc" "ppc/macosx" } + { "arm" "arm" } +} at "/bootstrap.factor" 3append parse-file "resource:core/bootstrap/layouts/layouts.factor" parse-file @@ -626,7 +626,7 @@ builtins get num-tags get tail f union-class define-class { "" "float-arrays" } { "curry" "kernel" } { "" "tuples.private" } - { "class-hash" "kernel.private" } + { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index e64295cc0c..a85e23100d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -58,17 +58,17 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ - { CHAR: \e CHAR: \\e } - { CHAR: \n CHAR: \\n } - { CHAR: \r CHAR: \\r } - { CHAR: \t CHAR: \\t } - { CHAR: \0 CHAR: \\0 } - { CHAR: \\ CHAR: \\\\ } - { CHAR: \" CHAR: \\\" } + { CHAR: \e CHAR: e } + { CHAR: \n CHAR: n } + { CHAR: \r CHAR: r } + { CHAR: \t CHAR: t } + { CHAR: \0 CHAR: 0 } + { CHAR: \\ CHAR: \\ } + { CHAR: \" CHAR: \" } } at ; : unparse-ch ( ch -- ) - dup ch>ascii-escape [ ] [ ] ?if , ; + dup ch>ascii-escape [ "\\" % ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) string-limit get [ diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 50c75d784e..bb3c94ce97 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -38,7 +38,7 @@ M: string set-nth-unsafe >r >fixnum >r >fixnum r> r> set-string-nth ; M: string clone - (clone) dup string-aux clone over set-string-aux ; + (clone) dup string-aux clone over set-string-aux ; M: string resize resize-string ;