Merge branch 'master' of git://factorcode.org/git/factor

Makefile

@@ -1,4 +1,5 @@
 CC = gcc
+CPP = g++
 AR = ar
 LD = ld
 
@@ -9,7 +10,7 @@ VERSION = 0.92
 
 BUNDLE = Factor.app
 LIBPATH = -L/usr/X11R6/lib
-CFLAGS = -Wall -Werror
+CFLAGS = -Wall
 
 ifdef DEBUG
 	CFLAGS += -g -DFACTOR_DEBUG
@@ -35,6 +36,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/code_block.o \
 	vm/code_gc.o \
 	vm/code_heap.o \
+	vm/contexts.o \
 	vm/data_gc.o \
 	vm/data_heap.o \
 	vm/debug.o \
@@ -45,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/inline_cache.o \
 	vm/io.o \
 	vm/jit.o \
+	vm/local_roots.o \
 	vm/math.o \
 	vm/primitives.o \
 	vm/profiler.o \
@@ -53,7 +56,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/strings.o \
 	vm/tuples.o \
 	vm/utilities.o \
-	vm/words.o
+	vm/words.o \
+	vm/write_barrier.o
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
@@ -161,12 +165,12 @@ macosx.app: factor
 
 $(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
 
 $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
 $(TEST_LIBRARY): vm/ffi_test.o
@@ -174,7 +178,13 @@ $(TEST_LIBRARY): vm/ffi_test.o
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
+	rm -f factor.dll
+	rm -f libfactor.*
+	rm -f libfactor-ffi-test.*
+	rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+
+tags:
+	etags vm/*.{cpp,hpp,mm,S,c}
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o
@@ -185,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c
 .c.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 
+.cpp.o:
+	$(CPP) -c $(CFLAGS) -o $@ $<
+
 .S.o:
 	$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
 
-.m.o:
+.mm.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
+	$(CPP) -c $(CFLAGS) -o $@ $<
 
-.PHONY: factor
+.PHONY: factor tags clean
+
+.SUFFIXES: .mm

README.txt

@@ -20,7 +20,7 @@ implementation. It is not an introduction to the language itself.
 
 * Compiling the Factor VM
 
-The Factor runtime is written in GNU C99, and is built with GNU make and
+The Factor runtime is written in GNU C++, and is built with GNU make and
 gcc.
 
 Factor supports various platforms. For an up-to-date list, see
@@ -138,7 +138,7 @@ usage documentation, enter the following in the UI listener:
 The Factor source tree is organized as follows:
 
   build-support/ - scripts used for compiling Factor
-  vm/ - sources for the Factor VM, written in C
+  vm/ - sources for the Factor VM, written in C++
   core/ - Factor core library
   basis/ - Factor basis library, compiler, tools
   extra/ - more libraries and applications

basis/alien/arrays/arrays.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays alien.c-types alien.structs
+USING: alien alien.strings alien.c-types alien.accessors alien.structs
-sequences math kernel namespaces fry libc cpu.architecture ;
+arrays words sequences math kernel namespaces fry libc cpu.architecture
+io.encodings.utf8 io.encodings.utf16n ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -38,3 +39,61 @@ M: value-type c-type-getter
 M: value-type c-type-setter ( type -- quot )
     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
     '[ @ swap @ _ memcpy ] ;
+
+PREDICATE: string-type < pair
+    first2 [ "char*" = ] [ word? ] bi* and ;
+
+M: string-type c-type ;
+
+M: string-type c-type-class
+    drop object ;
+
+M: string-type heap-size
+    drop "void*" heap-size ;
+
+M: string-type c-type-align
+    drop "void*" c-type-align ;
+
+M: string-type c-type-stack-align?
+    drop "void*" c-type-stack-align? ;
+
+M: string-type unbox-parameter
+    drop "void*" unbox-parameter ;
+
+M: string-type unbox-return
+    drop "void*" unbox-return ;
+
+M: string-type box-parameter
+    drop "void*" box-parameter ;
+
+M: string-type box-return
+    drop "void*" box-return ;
+
+M: string-type stack-size
+    drop "void*" stack-size ;
+
+M: string-type c-type-reg-class
+    drop int-regs ;
+
+M: string-type c-type-boxer
+    drop "void*" c-type-boxer ;
+
+M: string-type c-type-unboxer
+    drop "void*" c-type-unboxer ;
+
+M: string-type c-type-boxer-quot
+    second '[ _ alien>string ] ;
+
+M: string-type c-type-unboxer-quot
+    second '[ _ string>alien ] ;
+
+M: string-type c-type-getter
+    drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+    drop [ set-alien-cell ] ;
+
+{ "char*" utf8 } "char*" typedef
+"char*" "uchar*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+

basis/alien/c-types/c-types-docs.factor

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
-byte-arrays math strings hashtables alien.syntax
+byte-arrays math strings hashtables alien.syntax alien.strings sequences
-debugger destructors ;
+io.encodings.string debugger destructors ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -114,6 +114,38 @@ 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." } ;
 
+{ string>alien alien>string malloc-string } related-words
+
+HELP: malloc-string
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if one of the following conditions occurs:"
+    { $list
+        "the string contains null code points"
+        "the string contains characters not representable using the encoding specified"
+        "memory allocation fails"
+    }
+} ;
+
+ARTICLE: "c-strings" "C strings"
+"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
+$nl
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
+$nl
+"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
+{ $subsection string>alien }
+{ $subsection malloc-string }
+"The first allocates " { $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
+"A word to read strings from arbitrary addresses:"
+{ $subsection alien>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: "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

basis/alien/c-types/c-types.factor

@@ -2,9 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces make parser sequences strings words assocs splitting
-math.parser cpu.architecture alien alien.accessors quotations
+math.parser cpu.architecture alien alien.accessors alien.strings
-layouts system compiler.units io.files io.encodings.binary
+quotations layouts system compiler.units io io.files
-accessors combinators effects continuations fry classes ;
+io.encodings.binary io.streams.memory accessors combinators effects
+continuations fry classes ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -213,6 +214,15 @@ M: f byte-length drop 0 ;
 : memory>byte-array ( alien len -- byte-array )
     [ nip (byte-array) dup ] 2keep memcpy ;
 
+: malloc-string ( string encoding -- alien )
+    string>alien malloc-byte-array ;
+
+M: memory-stream stream-read
+    [
+        [ index>> ] [ alien>> ] bi <displaced-alien>
+        swap memory>byte-array
+    ] [ [ + ] change-index drop ] 2bi ;
+
 : byte-array>memory ( byte-array base -- )
     swap dup byte-length memcpy ;
 

basis/alien/libraries/libraries.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien assocs io.backend kernel namespaces ;
+USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
 IN: alien.libraries
 
+: dlopen ( path -- dll ) native-string>alien (dlopen) ;
+
+: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
+
 SYMBOL: libraries
 
 libraries [ H{ } clone ] initialize
@@ -18,4 +22,4 @@ TUPLE: library path abi dll ;
     library dup [ dll>> ] when ;
 
 : add-library ( name path abi -- )
-    <library> swap libraries get set-at ;
+    <library> swap libraries get set-at ;

basis/alien/strings/strings-docs.factor

@@ -1,52 +0,0 @@
-USING: help.markup help.syntax strings byte-arrays alien libc
-debugger io.encodings.string sequences ;
-IN: alien.strings
-
-HELP: string>alien
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
-{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
-
-{ string>alien alien>string malloc-string } related-words
-
-HELP: alien>string
-{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
-{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
-
-HELP: malloc-string
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
-{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if one of the following conditions occurs:"
-    { $list
-        "the string contains null code points"
-        "the string contains characters not representable using the encoding specified"
-        "memory allocation fails"
-    }
-} ;
-
-HELP: string>symbol
-{ $values { "str" string } { "alien" alien } }
-{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
-$nl
-"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
-
-ARTICLE: "c-strings" "C strings"
-"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
-$nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
-$nl
-"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
-$nl
-"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
-$nl
-"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
-{ $subsection string>alien }
-{ $subsection malloc-string }
-"The first allocates " { $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
-"A word to read strings from arbitrary addresses:"
-{ $subsection alien>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 } "." ;
-
-ABOUT: "c-strings"

basis/alien/strings/strings.factor

@@ -1,109 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays sequences kernel accessors math alien.accessors
-alien.c-types byte-arrays words io io.encodings
-io.encodings.utf8 io.streams.byte-array io.streams.memory system
-alien strings cpu.architecture fry vocabs.loader combinators ;
-IN: alien.strings
-
-GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
-
-M: c-ptr alien>string
-    [ <memory-stream> ] [ <decoder> ] bi*
-    "\0" swap stream-read-until drop ;
-
-M: f alien>string
-    drop ;
-
-ERROR: invalid-c-string string ;
-
-: check-string ( string -- )
-    0 over memq? [ invalid-c-string ] [ drop ] if ;
-
-GENERIC# string>alien 1 ( string encoding -- byte-array )
-
-M: c-ptr string>alien drop ;
-
-M: string string>alien
-    over check-string
-    <byte-writer>
-    [ stream-write ]
-    [ 0 swap stream-write1 ]
-    [ stream>> >byte-array ]
-    tri ;
-
-: malloc-string ( string encoding -- alien )
-    string>alien malloc-byte-array ;
-
-PREDICATE: string-type < pair
-    first2 [ "char*" = ] [ word? ] bi* and ;
-
-M: string-type c-type ;
-
-M: string-type c-type-class
-    drop object ;
-
-M: string-type heap-size
-    drop "void*" heap-size ;
-
-M: string-type c-type-align
-    drop "void*" c-type-align ;
-
-M: string-type c-type-stack-align?
-    drop "void*" c-type-stack-align? ;
-
-M: string-type unbox-parameter
-    drop "void*" unbox-parameter ;
-
-M: string-type unbox-return
-    drop "void*" unbox-return ;
-
-M: string-type box-parameter
-    drop "void*" box-parameter ;
-
-M: string-type box-return
-    drop "void*" box-return ;
-
-M: string-type stack-size
-    drop "void*" stack-size ;
-
-M: string-type c-type-reg-class
-    drop int-regs ;
-
-M: string-type c-type-boxer
-    drop "void*" c-type-boxer ;
-
-M: string-type c-type-unboxer
-    drop "void*" c-type-unboxer ;
-
-M: string-type c-type-boxer-quot
-    second '[ _ alien>string ] ;
-
-M: string-type c-type-unboxer-quot
-    second '[ _ string>alien ] ;
-
-M: string-type c-type-getter
-    drop [ alien-cell ] ;
-
-M: string-type c-type-setter
-    drop [ set-alien-cell ] ;
-
-HOOK: alien>native-string os ( alien -- string )
-
-HOOK: native-string>alien os ( string -- alien )
-
-: dll-path ( dll -- string )
-    path>> alien>native-string ;
-
-: string>symbol ( str -- alien )
-    dup string?
-    [ native-string>alien ]
-    [ [ native-string>alien ] map ] if ;
-
-{ "char*" utf8 } "char*" typedef
-"char*" "uchar*" typedef
-
-{
-    { [ os windows? ] [ "alien.strings.windows" require ] }
-    { [ os unix? ] [ "alien.strings.unix" require ] }
-} cond

basis/alien/strings/unix/summary.txt

@@ -1 +0,0 @@
-Default string encoding on Unix

basis/alien/strings/unix/unix.factor

@@ -1,8 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings io.encodings.utf8 system ;
-IN: alien.strings.unix
-
-M: unix alien>native-string utf8 alien>string ;
-
-M: unix native-string>alien utf8 string>alien ;

basis/alien/strings/windows/summary.txt

@@ -1 +0,0 @@
-Default string encoding on Windows

basis/alien/strings/windows/tags.txt

@@ -1 +0,0 @@
-unportable

basis/alien/strings/windows/windows.factor

@@ -1,13 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings alien.c-types io.encodings.utf8
-io.encodings.utf16n system ;
-IN: alien.strings.windows
-
-M: windows alien>native-string utf16n alien>string ;
-
-M: wince native-string>alien utf16n string>alien ;
-
-M: winnt native-string>alien utf8 string>alien ;
-
-{ "char*" utf16n } "wchar_t*" typedef

basis/bootstrap/stage2.factor

@@ -65,7 +65,6 @@ SYMBOL: bootstrap-time
         "stage2: deployment mode" print
     ] [
         "debugger" require
-        "alien.prettyprint" require
         "inspector" require
         "tools.errors" require
         "listener" require

basis/bootstrap/tools/tools.factor

@@ -14,7 +14,8 @@ IN: bootstrap.tools
     "tools.test"
     "tools.time"
     "tools.threads"
-    "tools.vocabs"
+    "vocabs.hierarchy"
-    "tools.vocabs.monitor"
+    "vocabs.refresh"
+    "vocabs.refresh.monitor"
     "editors"
 } [ require ] each

basis/command-line/command-line.factor

@@ -1,14 +1,14 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init continuations hashtables io io.encodings.utf8
 io.files io.pathnames kernel kernel.private namespaces parser
-sequences strings system splitting vocabs.loader ;
+sequences strings system splitting vocabs.loader alien.strings ;
 IN: command-line
 
 SYMBOL: script
 SYMBOL: command-line
 
-: (command-line) ( -- args ) 10 getenv sift ;
+: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
 
 : rc-path ( name -- path )
     os windows? [ "." prepend ] unless

basis/compiler/tests/simple.factor

@@ -60,8 +60,8 @@ IN: compiler.tests.simple
 
 ! Make sure error reporting works
 
-[ [ dup ] compile-call ] must-fail
+! [ [ dup ] compile-call ] must-fail
-[ [ drop ] compile-call ] must-fail
+! [ [ drop ] compile-call ] must-fail
 
 ! Regression
 

basis/debugger/debugger.factor

@@ -1,14 +1,13 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: slots arrays definitions generic hashtables summary io
+USING: slots arrays definitions generic hashtables summary io kernel
-kernel math namespaces make prettyprint prettyprint.config
+math namespaces make prettyprint prettyprint.config sequences assocs
-sequences assocs sequences.private strings io.styles
+sequences.private strings io.styles io.pathnames vectors words system
-io.pathnames vectors words system splitting math.parser
+splitting math.parser classes.mixin classes.tuple continuations
-classes.mixin classes.tuple continuations continuations.private
+continuations.private combinators generic.math classes.builtin classes
-combinators generic.math classes.builtin classes compiler.units
+compiler.units generic.standard generic.single vocabs init
-generic.standard generic.single vocabs init kernel.private io.encodings
+kernel.private io.encodings accessors math.order destructors
-accessors math.order destructors source-files parser
+source-files parser classes.tuple.parser effects.parser lexer
-classes.tuple.parser effects.parser lexer
 generic.parser strings.parser vocabs.loader vocabs.parser see
 source-files.errors ;
 IN: debugger
@@ -17,6 +16,7 @@ GENERIC: error. ( error -- )
 GENERIC: error-help ( error -- topic )
 
 M: object error. . ;
+
 M: object error-help drop f ;
 
 M: tuple error-help class ;
@@ -77,7 +77,7 @@ M: string error. print ;
     "Object did not survive image save/load: " write third . ;
 
 : io-error. ( error -- )
-    "I/O error: " write third print ;
+    "I/O error #" write third . ;
 
 : type-check-error. ( obj -- )
     "Type check error" print
@@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- )
     "Cannot convert to C string: " write third . ;
 
 : ffi-error. ( obj -- )
-    "FFI: " write
+    "FFI error" print drop ;
-    dup third [ write ": " write ] when*
-    fourth print ;
 
 : heap-scan-error. ( obj -- )
     "Cannot do next-object outside begin/end-scan" print drop ;

basis/editors/editors.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer kernel namespaces sequences definitions io.files
+USING: parser lexer kernel namespaces sequences definitions
-io.backend io.pathnames io summary continuations tools.crossref
+io.files io.backend io.pathnames io summary continuations
-tools.vocabs prettyprint source-files source-files.errors assocs
+tools.crossref vocabs.hierarchy prettyprint source-files
-vocabs vocabs.loader splitting accessors debugger prettyprint
+source-files.errors assocs vocabs vocabs.loader splitting
-help.topics ;
+accessors debugger prettyprint help.topics ;
 IN: editors
 
 TUPLE: no-edit-hook ;

basis/formatting/formatting.factor

@@ -4,7 +4,7 @@
 USING: accessors arrays ascii assocs calendar combinators fry kernel 
 generalizations io io.encodings.ascii io.files io.streams.string
 macros math math.functions math.parser peg.ebnf quotations
-sequences splitting strings unicode.case vectors ;
+sequences splitting strings unicode.case vectors combinators.smart ;
 
 IN: formatting
 
@@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
 : sprintf ( format-string -- result )
     [ printf ] with-string-writer ; inline
 
-
 <PRIVATE
 
 : pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
@@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
     [ pad-00 ] map "/" join ; inline
 
 : >datetime ( timestamp -- string )
-    { [ day-of-week day-abbreviation3 ]
+    [
-      [ month>> month-abbreviation ]
+       {
-      [ day>> pad-00 ]
+          [ day-of-week day-abbreviation3 ]
-      [ >time ]
+          [ month>> month-abbreviation ]
-      [ year>> number>string ]
+          [ day>> pad-00 ]
-    } cleave 5 narray " " join ; inline
+          [ >time ]
+          [ year>> number>string ]
+       } cleave
+    ] output>array " " join ; inline
 
 : (week-of-year) ( timestamp day -- n )
     [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@@ -187,5 +189,3 @@ PRIVATE>
 MACRO: strftime ( format-string -- )
     parse-strftime [ length ] keep [ ] join
     '[ _ <vector> @ reverse concat nip ] ;
-
-

basis/help/apropos/apropos.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry help.markup help.topics io
 kernel make math math.parser namespaces sequences sorting
-summary tools.completion tools.vocabs help.vocabs
+summary tools.completion vocabs.hierarchy help.vocabs
 vocabs words unicode.case help ;
 IN: help.apropos
 

basis/help/handbook/handbook.factor

@@ -281,7 +281,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
 { $heading "Workflow" }
 { $subsection "listener" }
 { $subsection "editor" }
-{ $subsection "tools.vocabs" }
+{ $subsection "vocabs.refresh" }
 { $subsection "tools.test" }
 { $subsection "help" }
 { $heading "Debugging" }
@@ -292,6 +292,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
 { $heading "Browsing" }
 { $subsection "see" }
 { $subsection "tools.crossref" }
+{ $subsection "vocabs.hierarchy" }
 { $heading "Performance" }
 { $subsection "timing" }
 { $subsection "profiling" }

basis/help/html/html.factor

@@ -3,7 +3,7 @@
 USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
 io.files io.files.temp io.directories html.streams help kernel
 assocs sequences make words accessors arrays help.topics vocabs
-tools.vocabs help.vocabs namespaces prettyprint io
+vocabs.hierarchy help.vocabs namespaces prettyprint io
 vocabs.loader serialize fry memoize ascii unicode.case math.order
 sorting debugger html xml.syntax xml.writer math.parser ;
 IN: help.html

basis/help/lint/lint.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs continuations fry help help.lint.checks
 help.topics io kernel namespaces parser sequences
-source-files.errors tools.vocabs vocabs words classes
+source-files.errors vocabs.hierarchy vocabs words classes
 locals tools.errors ;
 FROM: help.lint.checks => all-vocabs ;
 IN: help.lint

basis/help/tutorial/tutorial.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax ui.commands ui.operations
 editors vocabs.loader kernel sequences prettyprint tools.test
-tools.vocabs strings unicode.categories unicode.case
+vocabs.refresh strings unicode.categories unicode.case
 ui.tools.browser ui.tools.common ;
 IN: help.tutorial
 

basis/help/vocabs/vocabs.factor

@@ -6,7 +6,8 @@ classes.singleton classes.tuple classes.union combinators
 definitions effects fry generic help help.markup help.stylesheet
 help.topics io io.files io.pathnames io.styles kernel macros
 make namespaces prettyprint sequences sets sorting summary
-tools.vocabs vocabs vocabs.loader words words.symbol definitions.icons ;
+vocabs vocabs.files vocabs.hierarchy vocabs.loader
+vocabs.metadata words words.symbol definitions.icons ;
 IN: help.vocabs
 
 : about ( vocab -- )

basis/http/server/server-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ;
+USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ;
 IN: http.server
 
 HELP: trivial-responder

basis/http/server/server.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences arrays namespaces splitting
 vocabs.loader destructors assocs debugger continuations
-combinators tools.vocabs tools.time math math.parser present
+combinators vocabs.refresh tools.time math math.parser present
 io vectors
 io.sockets
 io.sockets.secure

basis/io/encodings/iana/iana.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel strings values io.files assocs
 splitting sequences io namespaces sets
-io.encodings.ascii io.encodings.utf8 ;
+io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
 IN: io.encodings.iana
 
 <PRIVATE
@@ -55,3 +55,6 @@ e>n-table [ initial-e>n ] initialize
     ] [ swap e>n-table get-global set-at ] 2bi ;
 
 ascii "ANSI_X3.4-1968" register-encoding
+utf16be "UTF-16BE" register-encoding
+utf16le "UTF-16LE" register-encoding
+utf16 "UTF-16" register-encoding

basis/json/reader/reader.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Peter Burns.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser math.private strings math
+USING: kernel peg peg.ebnf math.parser math.parser.private strings math
 math.functions sequences arrays vectors hashtables assocs
 prettyprint json ;
 IN: json.reader

basis/literals/literals-tests.factor

@@ -19,3 +19,9 @@ IN: literals.tests
 [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
 
 [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
+
+<<
+CONSTANT: constant-a 3
+>>
+
+[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test

basis/literals/literals.factor

@@ -1,6 +1,8 @@
 ! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations vectors ;
+USING: accessors continuations kernel parser words quotations
+combinators.smart vectors sequences ;
 IN: literals
 
 SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
 SYNTAX: $[ parse-quotation with-datastack >vector ;
+SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;

basis/present/present-tests.factor

@@ -1,5 +1,5 @@
 IN: present.tests
-USING: tools.test present math vocabs tools.vocabs sequences kernel ;
+USING: tools.test present math vocabs sequences kernel ;
 
 [ "3" ] [ 3 present ] unit-test
 [ "Hi" ] [ "Hi" present ] unit-test

basis/prettyprint/backend/backend.factor

@@ -1,11 +1,10 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays generic hashtables io assocs
+USING: accessors arrays byte-arrays byte-vectors generic hashtables io
-kernel math namespaces make sequences strings sbufs vectors
+assocs kernel math namespaces make sequences strings sbufs vectors
 words prettyprint.config prettyprint.custom prettyprint.sections
-quotations io io.pathnames io.styles math.parser effects
+quotations io io.pathnames io.styles math.parser effects classes.tuple
-classes.tuple math.order classes.tuple.private classes
+math.order classes.tuple.private classes combinators colors ;
-combinators colors ;
 IN: prettyprint.backend
 
 M: effect pprint* effect>string "(" ")" surround text ;
@@ -135,8 +134,8 @@ M: pathname pprint*
     [ text ] [ f <inset pprint* block> ] bi*
     \ } pprint-word block> ;
 
-M: tuple pprint*
+: pprint-tuple ( tuple -- )
-    boa-tuples? get [ call-next-method ] [
+    boa-tuples? get [ pprint-object ] [
         [
             <flow
             \ T{ pprint-word
@@ -149,6 +148,9 @@ M: tuple pprint*
         ] check-recursion
     ] if ;
 
+M: tuple pprint*
+    pprint-tuple ;
+
 : do-length-limit ( seq -- trimmed n/f )
     length-limit get dup [
         over length over [-]
@@ -165,6 +167,7 @@ M: curry pprint-delims drop \ [ \ ] ;
 M: compose pprint-delims drop \ [ \ ] ;
 M: array pprint-delims drop \ { \ } ;
 M: byte-array pprint-delims drop \ B{ \ } ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
 M: vector pprint-delims drop \ V{ \ } ;
 M: hashtable pprint-delims drop \ H{ \ } ;
 M: tuple pprint-delims drop \ T{ \ } ;
@@ -173,6 +176,7 @@ M: callstack pprint-delims drop \ CS{ \ } ;
 
 M: object >pprint-sequence ;
 M: vector >pprint-sequence ;
+M: byte-vector >pprint-sequence ;
 M: curry >pprint-sequence ;
 M: compose >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;
@@ -202,6 +206,7 @@ M: object pprint-object ( obj -- )
 
 M: object pprint* pprint-object ;
 M: vector pprint* pprint-object ;
+M: byte-vector pprint* pprint-object ;
 M: hashtable pprint* pprint-object ;
 M: curry pprint* pprint-object ;
 M: compose pprint* pprint-object ;

basis/stack-checker/known-words/known-words.factor

@@ -1,16 +1,16 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors alien alien.accessors arrays byte-arrays
+USING: fry accessors alien alien.accessors arrays byte-arrays classes
-classes sequences.private continuations.private effects generic
+sequences.private continuations.private effects generic hashtables
-hashtables hashtables.private io io.backend io.files
+hashtables.private io io.backend io.files io.files.private
-io.files.private io.streams.c kernel kernel.private math
+io.streams.c kernel kernel.private math math.private
-math.private memory namespaces namespaces.private parser
+math.parser.private memory memory.private namespaces
-quotations quotations.private sbufs sbufs.private
+namespaces.private parser quotations quotations.private sbufs
-sequences sequences.private slots.private strings
+sbufs.private sequences sequences.private slots.private strings
 strings.private system threads.private classes.tuple
-classes.tuple.private vectors vectors.private words definitions
+classes.tuple.private vectors vectors.private words definitions assocs
-assocs summary compiler.units system.private
+summary compiler.units system.private combinators
-combinators combinators.short-circuit locals locals.backend locals.types
+combinators.short-circuit locals locals.backend locals.types
 quotations.private combinators.private stack-checker.values
 generic.single generic.single.private
 alien.libraries
@@ -290,11 +290,11 @@ M: object infer-call*
 \ bignum>float { bignum } { float } define-primitive
 \ bignum>float make-foldable
 
-\ string>float { string } { float } define-primitive
+\ (string>float) { byte-array } { float } define-primitive
-\ string>float make-foldable
+\ (string>float) make-foldable
 
-\ float>string { float } { string } define-primitive
+\ (float>string) { float } { byte-array } define-primitive
-\ float>string make-foldable
+\ (float>string) make-foldable
 
 \ float>bits { real } { integer } define-primitive
 \ float>bits make-foldable
@@ -465,9 +465,9 @@ M: object infer-call*
 
 \ gc-stats { } { array } define-primitive
 
-\ save-image { string } { } define-primitive
+\ (save-image) { byte-array } { } define-primitive
 
-\ save-image-and-exit { string } { } define-primitive
+\ (save-image-and-exit) { byte-array } { } define-primitive
 
 \ data-room { } { integer integer array } define-primitive
 \ data-room make-flushable
@@ -481,9 +481,9 @@ M: object infer-call*
 \ tag { object } { fixnum } define-primitive
 \ tag make-foldable
 
-\ dlopen { string } { dll } define-primitive
+\ (dlopen) { byte-array } { dll } define-primitive
 
-\ dlsym { string object } { c-ptr } define-primitive
+\ (dlsym) { byte-array object } { c-ptr } define-primitive
 
 \ dlclose { dll } { } define-primitive
 
@@ -598,7 +598,7 @@ M: object infer-call*
 
 \ die { } { } define-primitive
 
-\ fopen { string string } { alien } define-primitive
+\ (fopen) { byte-array byte-array } { alien } define-primitive
 
 \ fgetc { alien } { object } define-primitive
 

basis/tools/completion/completion.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel arrays sequences math namespaces
+USING: accessors kernel arrays sequences math namespaces strings io
-strings io fry vectors words assocs combinators sorting
+fry vectors words assocs combinators sorting unicode.case
-unicode.case unicode.categories math.order vocabs
+unicode.categories math.order vocabs vocabs.hierarchy unicode.data
-tools.vocabs unicode.data locals ;
+locals ;
 IN: tools.completion
 
 :: (fuzzy) ( accum i full ch -- accum i full ? )

basis/tools/deploy/config/editor/editor.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs io.pathnames kernel parser prettyprint sequences
-splitting tools.deploy.config tools.vocabs vocabs.loader ;
+splitting tools.deploy.config vocabs.loader vocabs.metadata ;
 IN: tools.deploy.config.editor
 
 : deploy-config-path ( vocab -- string )

basis/tools/deploy/shaker/shaker.factor

@@ -37,7 +37,7 @@ IN: tools.deploy.shaker
     ] when
     strip-dictionary? [
         "compiler.units" init-hooks get delete-at
-        "tools.vocabs" init-hooks get delete-at
+        "vocabs.cache" init-hooks get delete-at
     ] when ;
 
 : strip-debugger ( -- )

basis/tools/test/test.factor

@@ -4,9 +4,9 @@ USING: accessors arrays assocs combinators compiler.units
 continuations debugger effects fry generalizations io io.files
 io.styles kernel lexer locals macros math.parser namespaces
 parser prettyprint quotations sequences source-files splitting
-stack-checker summary unicode.case vectors vocabs vocabs.loader words
+stack-checker summary unicode.case vectors vocabs vocabs.loader
-tools.vocabs tools.errors source-files.errors io.streams.string make
+vocabs.files words tools.errors source-files.errors
-compiler.errors ;
+io.streams.string make compiler.errors ;
 IN: tools.test
 
 TUPLE: test-failure < source-file-error continuation ;

basis/tools/vocabs/summary.txt

@@ -1 +0,0 @@
-Reloading vocabularies and cross-referencing vocabularies

basis/tools/vocabs/vocabs-docs.factor

@@ -1,75 +0,0 @@
-USING: help.markup help.syntax strings ;
-IN: tools.vocabs
-
-ARTICLE: "tools.vocabs" "Vocabulary tools"
-"Reloading source files changed on disk:"
-{ $subsection refresh }
-{ $subsection refresh-all }
-"Vocabulary summaries:"
-{ $subsection vocab-summary }
-{ $subsection set-vocab-summary }
-"Vocabulary tags:"
-{ $subsection vocab-tags }
-{ $subsection set-vocab-tags }
-{ $subsection add-vocab-tags }
-"Getting and setting vocabulary meta-data:"
-{ $subsection vocab-file-contents }
-{ $subsection set-vocab-file-contents }
-"Global meta-data:"
-{ $subsection all-vocabs }
-{ $subsection all-vocabs-seq }
-{ $subsection all-tags }
-{ $subsection all-authors }
-"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
-{ $subsection reset-cache } ;
-
-ABOUT: "tools.vocabs"
-
-HELP: vocab-files
-{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
-{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
-
-HELP: vocab-tests
-{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
-{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
-
-HELP: source-modified?
-{ $values { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ;
-
-HELP: refresh
-{ $values { "prefix" string } }
-{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
-
-HELP: refresh-all
-{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
-
-{ refresh refresh-all } related-words
-
-HELP: vocab-file-contents
-{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
-{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
-
-HELP: set-vocab-file-contents
-{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
-{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
-
-HELP: vocab-summary
-{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
-{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
-
-HELP: set-vocab-summary
-{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
-{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
-
-HELP: vocab-tags
-{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
-{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
-
-HELP: set-vocab-tags
-{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
-{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
-
-HELP: all-vocabs
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;

basis/tools/vocabs/vocabs-tests.factor

@@ -1,9 +0,0 @@
-IN: tools.vocabs.tests
-USING: tools.test tools.vocabs namespaces continuations ;
-
-[ ] [
-    changed-vocabs get-global
-    f changed-vocabs set-global
-    [ t ] [ "kernel" changed-vocab? ] unit-test
-    [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
-] unit-test

basis/tools/vocabs/vocabs.factor

@@ -1,296 +0,0 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io io.styles io.files io.files.info io.directories
-io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences
-namespaces make math.parser arrays hashtables assocs memoize
-summary sorting splitting combinators source-files debugger
-continuations compiler.errors init checksums checksums.crc32
-sets accessors generic definitions words ;
-IN: tools.vocabs
-
-: vocab-tests-file ( vocab -- path )
-    dup "-tests.factor" vocab-dir+ vocab-append-path dup
-    [ dup exists? [ drop f ] unless ] [ drop f ] if ;
-
-: vocab-tests-dir ( vocab -- paths )
-    dup vocab-dir "tests" append-path vocab-append-path dup [
-        dup exists? [
-            dup directory-files [ ".factor" tail? ] filter
-            [ append-path ] with map
-        ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: vocab-tests ( vocab -- tests )
-    [
-        [ vocab-tests-file [ , ] when* ]
-        [ vocab-tests-dir [ % ] when* ] bi
-    ] { } make ;
-
-: vocab-files ( vocab -- seq )
-    [
-        [ vocab-source-path [ , ] when* ]
-        [ vocab-docs-path [ , ] when* ]
-        [ vocab-tests % ] tri
-    ] { } make ;
-
-: vocab-heading. ( vocab -- )
-    nl
-    "==== " write
-    [ vocab-name ] [ vocab write-object ] bi ":" print
-    nl ;
-
-: load-error. ( triple -- )
-    [ first vocab-heading. ] [ second print-error ] bi ;
-
-: load-failures. ( failures -- )
-    [ load-error. nl ] each ;
-
-SYMBOL: failures
-
-: require-all ( vocabs -- failures )
-    [
-        V{ } clone blacklist set
-        V{ } clone failures set
-        [
-            [ require ]
-            [ swap vocab-name failures get set-at ]
-            recover
-        ] each
-        failures get
-    ] with-scope ;
-
-: source-modified? ( path -- ? )
-    dup source-files get at [
-        dup path>>
-        dup exists? [
-            utf8 file-lines crc32 checksum-lines
-            swap checksum>> = not
-        ] [
-            2drop f
-        ] if
-    ] [
-        exists?
-    ] ?if ;
-
-SYMBOL: changed-vocabs
-
-: changed-vocab ( vocab -- )
-    dup vocab changed-vocabs get and
-    [ dup changed-vocabs get set-at ] [ drop ] if ;
-
-: unchanged-vocab ( vocab -- )
-    changed-vocabs get delete-at ;
-
-: unchanged-vocabs ( vocabs -- )
-    [ unchanged-vocab ] each ;
-
-: changed-vocab? ( vocab -- ? )
-    changed-vocabs get dup [ key? ] [ 2drop t ] if ;
-
-: filter-changed ( vocabs -- vocabs' )
-    [ changed-vocab? ] filter ;
-
-SYMBOL: modified-sources
-SYMBOL: modified-docs
-
-: (to-refresh) ( vocab variable loaded? path -- )
-    dup [
-        swap [
-            pick changed-vocab? [
-                source-modified? [ get push ] [ 2drop ] if
-            ] [ 3drop ] if
-        ] [ drop get push ] if
-    ] [ 2drop 2drop ] if ;
-
-: to-refresh ( prefix -- modified-sources modified-docs unchanged )
-    [
-        V{ } clone modified-sources set
-        V{ } clone modified-docs set
-
-        child-vocabs [
-            [
-                [
-                    [ modified-sources ]
-                    [ vocab source-loaded?>> ]
-                    [ vocab-source-path ]
-                    tri (to-refresh)
-                ] [
-                    [ modified-docs ]
-                    [ vocab docs-loaded?>> ]
-                    [ vocab-docs-path ]
-                    tri (to-refresh)
-                ] bi
-            ] each
-
-            modified-sources get
-            modified-docs get
-        ]
-        [ modified-docs get modified-sources get append diff ] bi
-    ] with-scope ;
-
-: do-refresh ( modified-sources modified-docs unchanged -- )
-    unchanged-vocabs
-    [
-        [ [ vocab f >>source-loaded? drop ] each ]
-        [ [ vocab f >>docs-loaded? drop ] each ] bi*
-    ]
-    [
-        append prune
-        [ unchanged-vocabs ]
-        [ require-all load-failures. ] bi
-    ] 2bi ;
-
-: refresh ( prefix -- ) to-refresh do-refresh ;
-
-: refresh-all ( -- ) "" refresh ;
-
-MEMO: vocab-file-contents ( vocab name -- seq )
-    vocab-append-path dup
-    [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
-
-: set-vocab-file-contents ( seq vocab name -- )
-    dupd vocab-append-path [
-        utf8 set-file-lines
-        \ vocab-file-contents reset-memoized
-    ] [
-        "The " swap vocab-name
-        " vocabulary was not loaded from the file system"
-        3append throw
-    ] ?if ;
-
-: vocab-summary-path ( vocab -- string )
-    vocab-dir "summary.txt" append-path ;
-
-: vocab-summary ( vocab -- summary )
-    dup dup vocab-summary-path vocab-file-contents
-    [
-        vocab-name " vocabulary" append
-    ] [
-        nip first
-    ] if-empty ;
-
-M: vocab summary
-    [
-        dup vocab-summary %
-        " (" %
-        words>> assoc-size #
-        " words)" %
-    ] "" make ;
-
-M: vocab-link summary vocab-summary ;
-
-: set-vocab-summary ( string vocab -- )
-    [ 1array ] dip
-    dup vocab-summary-path
-    set-vocab-file-contents ;
-
-: vocab-tags-path ( vocab -- string )
-    vocab-dir "tags.txt" append-path ;
-
-: vocab-tags ( vocab -- tags )
-    dup vocab-tags-path vocab-file-contents harvest ;
-
-: set-vocab-tags ( tags vocab -- )
-    dup vocab-tags-path set-vocab-file-contents ;
-
-: add-vocab-tags ( tags vocab -- )
-    [ vocab-tags append prune ] keep set-vocab-tags ;
-
-: vocab-authors-path ( vocab -- string )
-    vocab-dir "authors.txt" append-path ;
-
-: vocab-authors ( vocab -- authors )
-    dup vocab-authors-path vocab-file-contents harvest ;
-
-: set-vocab-authors ( authors vocab -- )
-    dup vocab-authors-path set-vocab-file-contents ;
-
-: subdirs ( dir -- dirs )
-    [
-        [ link-info directory? ] filter
-    ] with-directory-files natural-sort ;
-
-: (all-child-vocabs) ( root name -- vocabs )
-    [
-        vocab-dir append-path dup exists?
-        [ subdirs ] [ drop { } ] if
-    ] keep [
-        swap [ "." glue ] with map
-    ] unless-empty ;
-
-: vocab-dir? ( root name -- ? )
-    over
-    [ ".factor" vocab-dir+ append-path exists? ]
-    [ 2drop f ]
-    if ;
-
-: vocabs-in-dir ( root name -- )
-    dupd (all-child-vocabs) [
-        2dup vocab-dir? [ dup >vocab-link , ] when
-        vocabs-in-dir
-    ] with each ;
-
-: all-vocabs ( -- assoc )
-    vocab-roots get [
-        dup [ "" vocabs-in-dir ] { } make
-    ] { } map>assoc ;
-
-MEMO: all-vocabs-seq ( -- seq )
-    all-vocabs values concat ;
-
-: unportable? ( name -- ? )
-    vocab-tags "unportable" swap member? ;
-
-: filter-unportable ( seq -- seq' )
-    [ vocab-name unportable? not ] filter ;
-
-: try-everything ( -- failures )
-    all-vocabs-seq
-    filter-unportable
-    require-all ;
-
-: load-everything ( -- )
-    try-everything load-failures. ;
-
-: unrooted-child-vocabs ( prefix -- seq )
-    dup empty? [ CHAR: . suffix ] unless
-    vocabs
-    [ find-vocab-root not ] filter
-    [
-        vocab-name swap ?head CHAR: . rot member? not and
-    ] with filter
-    [ vocab ] map ;
-
-: all-child-vocabs ( prefix -- assoc )
-    vocab-roots get [
-        dup pick (all-child-vocabs) [ >vocab-link ] map
-    ] { } map>assoc
-    swap unrooted-child-vocabs f swap 2array suffix ;
-
-: all-child-vocabs-seq ( prefix -- assoc )
-    vocab-roots get swap [
-        dupd (all-child-vocabs)
-        [ vocab-dir? ] with filter
-    ] curry map concat ;
-
-MEMO: all-tags ( -- seq )
-    all-vocabs-seq [ vocab-tags ] gather natural-sort ;
-
-MEMO: all-authors ( -- seq )
-    all-vocabs-seq [ vocab-authors ] gather natural-sort ;
-
-: reset-cache ( -- )
-    root-cache get-global clear-assoc
-    \ vocab-file-contents reset-memoized
-    \ all-vocabs-seq reset-memoized
-    \ all-authors reset-memoized
-    \ all-tags reset-memoized ;
-
-SINGLETON: cache-observer
-
-M: cache-observer vocabs-changed drop reset-cache ;
-
-[
-    f changed-vocabs set-global
-    cache-observer add-vocab-observer
-] "tools.vocabs" add-init-hook

basis/ui/backend/cocoa/tools/tools.factor

@@ -4,7 +4,8 @@ USING: alien.syntax cocoa cocoa.nibs cocoa.application
 cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
 core-foundation core-foundation.strings help.topics kernel
 memory namespaces parser system ui ui.tools.browser
-ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ;
+ui.tools.listener ui.backend.cocoa eval locals
+vocabs.refresh ;
 IN: ui.backend.cocoa.tools
 
 : finder-run-files ( alien -- )

basis/ui/backend/cocoa/views/views.factor

@@ -9,7 +9,7 @@ threads combinators math.rectangles ;
 IN: ui.backend.cocoa.views
 
 : send-mouse-moved ( view event -- )
-    [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
+    [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
 
 : button ( event -- n )
     #! Cocoa -> Factor UI button mapping

basis/ui/gadgets/gadgets.factor

@@ -3,7 +3,8 @@
 USING: accessors arrays hashtables kernel models math namespaces
 make sequences quotations math.vectors combinators sorting
 binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals ;
+concurrency.flags math.order math.rectangles fry locals
+prettyprint.backend prettyprint.custom ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -27,6 +28,9 @@ interior
 boundary
 model ;
 
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;
+
 M: gadget equal? 2drop f ;
 
 M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;

basis/ui/gadgets/status-bar/status-bar-docs.factor

@@ -18,7 +18,7 @@ HELP: <status-bar>
 { $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
 
 HELP: open-status-window
-{ $values { "gadget" gadget } { "title" string } }
+{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
 { $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." }
 { $see-also show-status hide-status } ;
 
@@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help"
 { $subsection hide-status }
 { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ;
 
-ABOUT: "ui.gadgets.status-bar"
+ABOUT: "ui.gadgets.status-bar"

basis/ui/gadgets/status-bar/status-bar.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors models models.delay models.arrow
 sequences ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
+ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
 IN: ui.gadgets.status-bar
 
 : <status-bar> ( model -- gadget )
@@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar
     reverse-video-theme
     t >>root? ;
 
-: open-status-window ( gadget title -- )
+: open-status-window ( gadget title/attributes -- )
-    f <model> [ <world> ] keep
+    ?attributes f <model> >>status <world>
-    <status-bar> f track-add
+    dup status>> <status-bar> f track-add
     open-world-window ;
 
 : show-summary ( object gadget -- )

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -48,8 +48,8 @@ HELP: world
 } ;
 
 HELP: <world>
-{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
+{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } }
-{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
+{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ;
 
 HELP: find-world
 { $values { "gadget" gadget } { "world/f" { $maybe world } } }
@@ -65,6 +65,30 @@ HELP: find-gl-context
 { $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." }
 { $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ;
 
+HELP: begin-world
+{ $values { "world" world } }
+{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ;
+
+HELP: end-world
+{ $values { "world" world } }
+{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ;
+
+HELP: resize-world
+{ $values { "world" world } }
+{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ;
+
+HELP: draw-world*
+{ $values { "world" world } }
+{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ;
+
+ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds"
+"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:"
+{ $subsection begin-world }
+{ $subsection end-world }
+{ $subsection resize-world }
+{ $subsection draw-world* }
+"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ;
+
 ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
 "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
 { $subsection draw-gadget* }
@@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
 $nl
 "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:"
 { $subsection find-gl-context }
-"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
+"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "."
 { $subsection "ui-paint-coord" }
+{ $subsection "ui.gadgets.worlds-subclassing" }
 { $subsection "gl-utilities" }
 { $subsection "text-rendering" } ;

basis/ui/gadgets/worlds/worlds.factor

@@ -4,15 +4,28 @@ USING: accessors arrays assocs continuations kernel math models
 namespaces opengl opengl.textures sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors ;
+ui.commands ui.pixel-formats destructors literals ;
 IN: ui.gadgets.worlds
 
+CONSTANT: default-world-pixel-format-attributes
+    { windowed double-buffered T{ depth-bits { value 16 } } }
+
 TUPLE: world < track
-active? focused?
+    active? focused?
-layers
+    layers
-title status status-owner
+    title status status-owner
-text-handle handle images
+    text-handle handle images
-window-loc ;
+    window-loc
+    pixel-format-attributes ;
+
+TUPLE: world-attributes
+    { world-class initial: world }
+    title
+    status
+    gadgets
+    { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+
+C: <world-attributes> world-attributes
 
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
 
@@ -45,18 +58,23 @@ M: world request-focus-on ( child gadget -- )
     2dup eq?
     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
 
-: new-world ( gadget title status class -- world )
+: new-world ( class -- world )
     vertical swap new-track
         t >>root?
         t >>active?
-        { 0 0 } >>window-loc
+        { 0 0 } >>window-loc ;
-        swap >>status
-        swap >>title
-        swap 1 track-add
-    dup request-focus ;
 
-: <world> ( gadget title status -- world )
+: apply-world-attributes ( world attributes -- world )
-    world new-world ;
+    {
+        [ title>> >>title ]
+        [ status>> >>status ]
+        [ pixel-format-attributes>> >>pixel-format-attributes ]
+        [ gadgets>> [ 1 track-add ] each ]
+    } cleave ;
+
+: <world> ( world-attributes -- world )
+    [ world-class>> new-world ] keep apply-world-attributes
+    dup request-focus ;
 
 : as-big-as-possible ( world gadget -- )
     dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
@@ -77,17 +95,36 @@ SYMBOL: flush-layout-cache-hook
 
 flush-layout-cache-hook [ [ ] ] initialize
 
-: (draw-world) ( world -- )
+GENERIC: begin-world ( world -- )
-    dup handle>> [
+GENERIC: end-world ( world -- )
-        check-extensions
+
-        {
+GENERIC: resize-world ( world -- )
-            [ init-gl ]
+
-            [ draw-gadget ]
+M: world begin-world
-            [ text-handle>> [ purge-cache ] when* ]
+    drop ;
-            [ images>> [ purge-cache ] when* ]
+M: world end-world
-        } cleave
+    drop ;
-    ] with-gl-context
+M: world resize-world
-    flush-layout-cache-hook get call( -- ) ;
+    drop ;
+
+M: world (>>dim)
+    [ call-next-method ]
+    [
+        dup handle>>
+        [ select-gl-context resize-world ]
+        [ drop ] if*
+    ] bi ;
+
+GENERIC: draw-world* ( world -- )
+
+M: world draw-world*
+    check-extensions
+    {
+        [ init-gl ]
+        [ draw-gadget ]
+        [ text-handle>> [ purge-cache ] when* ]
+        [ images>> [ purge-cache ] when* ]
+    } cleave ;
 
 : draw-world? ( world -- ? )
     #! We don't draw deactivated worlds, or those with 0 size.
@@ -108,7 +145,10 @@ ui-error-hook [ [ rethrow ] ] initialize
 : draw-world ( world -- )
     dup draw-world? [
         dup world [
-            [ (draw-world) ] [
+            [
+                dup handle>> [ draw-world* ] with-gl-context
+                flush-layout-cache-hook get call( -- )
+            ] [
                 over <world-error> ui-error
                 f >>active? drop
             ] recover
@@ -151,8 +191,7 @@ M: world handle-gesture ( gesture gadget -- ? )
     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
 
 M: world world-pixel-format-attributes
-    drop
+    pixel-format-attributes>> ;
-    { windowed double-buffered T{ depth-bits { value 16 } } } ;
 
 M: world check-world-pixel-format
     2drop ;
@@ -160,3 +199,4 @@ M: world check-world-pixel-format
 : with-world-pixel-format ( world quot -- )
     [ dup dup world-pixel-format-attributes <pixel-format> ]
     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
+

basis/ui/pixel-formats/pixel-formats-docs.factor

@@ -91,29 +91,29 @@ HELP: backing-store
 { double-buffered backing-store } related-words
 
 HELP: multisampled
-{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." }
+{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." }
 { $notes "On some window systems this is not distinct from " { $link supersampled } "." } ;
 
 HELP: supersampled
-{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." }
+{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." }
 { $notes "On some window systems this is not distinct from " { $link multisampled } "." } ;
 
 HELP: sample-alpha
 { $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ;
 
 HELP: color-float
-{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ;
+{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ;
 
 HELP: color-bits
-{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ;
 HELP: red-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
 HELP: green-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ;
 HELP: blue-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
 HELP: alpha-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
 
 { color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words
 

basis/ui/tools/listener/listener-docs.factor

@@ -1,7 +1,7 @@
 USING: help.markup help.syntax ui.commands ui.operations
 ui.gadgets.editors ui.gadgets.panes listener io words
 ui.tools.listener.completion ui.tools.common help.tips
-tools.vocabs vocabs ;
+vocabs vocabs.refresh ;
 IN: ui.tools.listener
 
 HELP: interactor

basis/ui/tools/listener/listener.factor

@@ -6,14 +6,15 @@ compiler.units help.tips concurrency.flags concurrency.mailboxes
 continuations destructors documents documents.elements fry hashtables
 help help.markup io io.styles kernel lexer listener math models sets
 models.delay models.arrow namespaces parser prettyprint quotations
-sequences strings threads tools.vocabs vocabs vocabs.loader
+sequences strings threads vocabs vocabs.refresh vocabs.loader
 vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
 ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
 ui.tools.listener.completion ui.tools.listener.popups
-ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ;
+ui.tools.listener.history ui.images ui.tools.error-list
+tools.errors.model ;
 FROM: source-files.errors => all-errors ;
 IN: ui.tools.listener
 

basis/ui/tools/operations/operations.factor

@@ -4,7 +4,7 @@ USING: continuations definitions generic help.topics threads
 stack-checker summary io.pathnames io.styles kernel namespaces parser
 prettyprint quotations tools.crossref tools.annotations editors
 tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
-words sequences tools.vocabs classes compiler.errors compiler.units
+words sequences classes compiler.errors compiler.units
 accessors vocabs.parser macros.expander ui ui.tools.browser
 ui.tools.listener ui.tools.listener.completion ui.tools.profiler
 ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors

basis/ui/tools/tools.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: memory system kernel tools.vocabs ui.tools.operations
+USING: memory system kernel vocabs.refresh ui.tools.operations
 ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
 ui.tools.walker ui.commands ui.gestures ui ui.private ;
 IN: ui.tools

basis/ui/ui-docs.factor

@@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger
 namespaces ui.backend ui.gadgets ui.gadgets.worlds
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
 ui.gadgets.private math.rectangles colors ui.text fonts
-kernel ui.private ;
+kernel ui.private classes sequences ;
 IN: ui
 
 HELP: windows
 { $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
 
-{ windows open-window find-window } related-words
+{ windows open-window find-window world-attributes } related-words
 
 HELP: open-window
-{ $values { "gadget" gadget } { "title" string } }
+{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
-{ $description "Opens a native window with the specified title." } ;
+{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
+
+HELP: world-attributes
+{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
+{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
+{ $list
+    { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." }
+    { { $snippet "title" } " is the window title." }
+    { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
+    { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
+    { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
+} ;
 
 HELP: set-fullscreen?
 { $values { "?" "a boolean" } { "gadget" gadget } }

basis/ui/ui.factor

@@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists
 deques sequences threads sequences words continuations init
 combinators combinators.short-circuit hashtables concurrency.flags
 sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
+strings ;
 IN: ui
 
 <PRIVATE
@@ -49,8 +50,20 @@ SYMBOL: windows
     f >>focused?
     focus-path f swap focus-gestures ;
 
+: try-to-open-window ( world -- )
+    {
+        [ (open-window) ]
+        [ handle>> select-gl-context ]
+        [
+            [ begin-world ]
+            [ [ handle>> (close-window) ] [ ui-error ] bi* ]
+            recover
+        ]
+        [ resize-world ]
+    } cleave ;
+
 M: world graft*
-    [ (open-window) ]
+    [ try-to-open-window ]
     [ [ title>> ] keep set-title ]
     [ request-focus ] tri ;
 
@@ -66,6 +79,7 @@ M: world graft*
         [ images>> [ dispose ] when* ]
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
+        [ end-world ]
     } cleave ;
 
 M: world ungraft*
@@ -166,13 +180,17 @@ PRIVATE>
 : restore-windows? ( -- ? )
     windows get empty? not ;
 
+: ?attributes ( gadget title/attributes -- attributes )
+    dup string? [ world-attributes new swap >>title ] when
+    swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
+
 PRIVATE>
 
 : open-world-window ( world -- )
     dup pref-dim >>dim dup relayout graft ;
 
-: open-window ( gadget title -- )
+: open-window ( gadget title/attributes -- )
-    f <world> open-world-window ;
+    ?attributes <world> open-world-window ;
 
 : set-fullscreen? ( ? gadget -- )
     find-world set-fullscreen* ;

basis/vocabs/cache/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/vocabs/cache/cache.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel namespaces memoize init vocabs
+vocabs.hierarchy vocabs.loader vocabs.metadata vocabs.refresh ;
+IN: vocabs.cache
+
+: reset-cache ( -- )
+    root-cache get-global clear-assoc
+    \ vocab-file-contents reset-memoized
+    \ all-vocabs-seq reset-memoized
+    \ all-authors reset-memoized
+    \ all-tags reset-memoized ;
+
+SINGLETON: cache-observer
+
+M: cache-observer vocabs-changed drop reset-cache ;
+
+[
+    f changed-vocabs set-global
+    cache-observer add-vocab-observer
+] "vocabs.cache" add-init-hook

basis/vocabs/cache/summary.txt

@@ -0,0 +1 @@
+Caching vocabulary data from disk

basis/vocabs/errors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/vocabs/errors/errors.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs continuations debugger io io.styles kernel
+namespaces sequences vocabs vocabs.loader ;
+IN: vocabs.errors
+
+<PRIVATE
+
+: vocab-heading. ( vocab -- )
+    nl
+    "==== " write
+    [ vocab-name ] [ vocab write-object ] bi ":" print
+    nl ;
+
+: load-error. ( triple -- )
+    [ first vocab-heading. ] [ second print-error ] bi ;
+
+SYMBOL: failures
+
+PRIVATE>
+
+: load-failures. ( failures -- )
+    [ load-error. nl ] each ;
+
+: require-all ( vocabs -- failures )
+    [
+        V{ } clone blacklist set
+        V{ } clone failures set
+        [
+            [ require ]
+            [ swap vocab-name failures get set-at ]
+            recover
+        ] each
+        failures get
+    ] with-scope ;

basis/vocabs/errors/summary.txt

@@ -0,0 +1 @@
+Loading vocabularies and batching errors

basis/vocabs/files/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/vocabs/files/files-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax strings ;
+IN: vocabs.files
+
+HELP: vocab-files
+{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
+{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
+
+HELP: vocab-tests
+{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
+{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
+

basis/vocabs/files/files.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.directories io.files io.pathnames kernel make
+sequences vocabs.loader ;
+IN: vocabs.files
+
+<PRIVATE
+
+: vocab-tests-file ( vocab -- path )
+    dup "-tests.factor" vocab-dir+ vocab-append-path dup
+    [ dup exists? [ drop f ] unless ] [ drop f ] if ;
+
+: vocab-tests-dir ( vocab -- paths )
+    dup vocab-dir "tests" append-path vocab-append-path dup [
+        dup exists? [
+            dup directory-files [ ".factor" tail? ] filter
+            [ append-path ] with map
+        ] [ drop f ] if
+    ] [ drop f ] if ;
+
+PRIVATE>
+
+: vocab-tests ( vocab -- tests )
+    [
+        [ vocab-tests-file [ , ] when* ]
+        [ vocab-tests-dir [ % ] when* ] bi
+    ] { } make ;
+
+: vocab-files ( vocab -- seq )
+    [
+        [ vocab-source-path [ , ] when* ]
+        [ vocab-docs-path [ , ] when* ]
+        [ vocab-tests % ] tri
+    ] { } make ;

basis/vocabs/files/summary.txt

@@ -0,0 +1 @@
+Getting a list of files in a vocabulary

basis/vocabs/hierarchy/hierarchy-docs.factor

@@ -0,0 +1,33 @@
+USING: help.markup help.syntax strings vocabs.loader ;
+IN: vocabs.hierarchy
+
+ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools"
+"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not."
+$nl
+"Loading vocabulary hierarchies:"
+{ $subsection load }
+{ $subsection load-all }
+"Getting all vocabularies on disk:"
+{ $subsection all-vocabs }
+{ $subsection all-vocabs-seq }
+"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"
+{ $subsection all-tags }
+{ $subsection all-authors } ;
+
+ABOUT: "vocabs.hierarchy"
+
+HELP: all-vocabs
+{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
+{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
+
+HELP: load
+{ $values { "prefix" string } }
+{ $description "Load all vocabularies that match the provided prefix." }
+{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ;
+
+HELP: load-all
+{ $description "Load all vocabularies in the source tree." } ;
+
+HELP: all-vocabs-under
+{ $values { "prefix" string } }
+{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;

basis/vocabs/hierarchy/hierarchy-tests.factor

@@ -0,0 +1,12 @@
+IN: vocabs.hierarchy.tests
+USING: continuations namespaces tools.test vocabs.hierarchy vocabs.hierarchy.private ;
+
+[ ] [
+    changed-vocabs get-global
+    f changed-vocabs set-global
+    [ t ] [ "kernel" changed-vocab? ] unit-test
+    [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+] unit-test
+
+[ t ] [ "some-vocab" valid-vocab-dirname ] unit-test
+[ f ] [ ".git" valid-vocab-dirname ] unit-test

basis/vocabs/hierarchy/hierarchy.factor

@@ -0,0 +1,99 @@
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators.short-circuit fry
+io.directories io.files io.files.info io.pathnames kernel make
+memoize namespaces sequences sorting splitting vocabs sets
+vocabs.loader vocabs.metadata vocabs.errors ;
+IN: vocabs.hierarchy
+
+<PRIVATE
+
+: vocab-subdirs ( dir -- dirs )
+    [
+        [
+            { [ link-info directory? ] [ "." head? not ] } 1&&
+        ] filter
+    ] with-directory-files natural-sort ;
+
+: (all-child-vocabs) ( root name -- vocabs )
+    [
+        vocab-dir append-path dup exists?
+        [ vocab-subdirs ] [ drop { } ] if
+    ] keep
+    [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;
+
+: vocab-dir? ( root name -- ? )
+    over
+    [ ".factor" vocab-dir+ append-path exists? ]
+    [ 2drop f ]
+    if ;
+
+: vocabs-in-dir ( root name -- )
+    dupd (all-child-vocabs) [
+        2dup vocab-dir? [ dup >vocab-link , ] when
+        vocabs-in-dir
+    ] with each ;
+
+PRIVATE>
+
+: all-vocabs ( -- assoc )
+    vocab-roots get [
+        dup [ "" vocabs-in-dir ] { } make
+    ] { } map>assoc ;
+
+: all-vocabs-under ( prefix -- vocabs )
+    [
+        [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
+    ] { } make ;
+
+MEMO: all-vocabs-seq ( -- seq )
+    "" all-vocabs-under ;
+
+<PRIVATE
+
+: unrooted-child-vocabs ( prefix -- seq )
+    dup empty? [ CHAR: . suffix ] unless
+    vocabs
+    [ find-vocab-root not ] filter
+    [
+        vocab-name swap ?head CHAR: . rot member? not and
+    ] with filter
+    [ vocab ] map ;
+
+PRIVATE>
+
+: all-child-vocabs ( prefix -- assoc )
+    vocab-roots get [
+        dup pick (all-child-vocabs) [ >vocab-link ] map
+    ] { } map>assoc
+    swap unrooted-child-vocabs f swap 2array suffix ;
+
+: all-child-vocabs-seq ( prefix -- assoc )
+    vocab-roots get swap '[
+        dup _ (all-child-vocabs)
+        [ vocab-dir? ] with filter
+    ] map concat ;
+
+<PRIVATE
+
+: filter-unportable ( seq -- seq' )
+    [ vocab-name unportable? not ] filter ;
+
+PRIVATE>
+
+: (load) ( prefix -- failures )
+    all-vocabs-under
+    filter-unportable
+    require-all ;
+
+: load ( prefix -- )
+    (load) load-failures. ;
+
+: load-all ( -- )
+    "" load ;
+
+MEMO: all-tags ( -- seq )
+    all-vocabs-seq [ vocab-tags ] gather natural-sort ;
+
+MEMO: all-authors ( -- seq )
+    all-vocabs-seq [ vocab-authors ] gather natural-sort ;

basis/vocabs/hierarchy/summary.txt

@@ -0,0 +1 @@
+Searching for vocabularies on disk

basis/vocabs/metadata/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/vocabs/metadata/metadata-docs.factor

@@ -0,0 +1,44 @@
+USING: help.markup help.syntax strings ;
+IN: vocabs.metadata
+
+ARTICLE: "vocabs.metadata" "Vocabulary metadata"
+"Vocabulary summaries:"
+{ $subsection vocab-summary }
+{ $subsection set-vocab-summary }
+"Vocabulary authors:"
+{ $subsection vocab-authors }
+{ $subsection set-vocab-authors }
+"Vocabulary tags:"
+{ $subsection vocab-tags }
+{ $subsection set-vocab-tags }
+{ $subsection add-vocab-tags }
+"Getting and setting arbitrary vocabulary metadata:"
+{ $subsection vocab-file-contents }
+{ $subsection set-vocab-file-contents } ;
+
+ABOUT: "vocabs.metadata"
+
+HELP: vocab-file-contents
+{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
+{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
+
+HELP: set-vocab-file-contents
+{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
+{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
+
+HELP: vocab-summary
+{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
+{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
+
+HELP: set-vocab-summary
+{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
+{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
+
+HELP: vocab-tags
+{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
+{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
+
+HELP: set-vocab-tags
+{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
+{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
+

basis/vocabs/metadata/metadata.factor

@@ -0,0 +1,70 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs io.encodings.utf8 io.files
+io.pathnames kernel make math.parser memoize sequences sets
+sorting summary vocabs vocabs.loader ;
+IN: vocabs.metadata
+
+MEMO: vocab-file-contents ( vocab name -- seq )
+    vocab-append-path dup
+    [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
+
+: set-vocab-file-contents ( seq vocab name -- )
+    dupd vocab-append-path [
+        utf8 set-file-lines
+        \ vocab-file-contents reset-memoized
+    ] [
+        "The " swap vocab-name
+        " vocabulary was not loaded from the file system"
+        3append throw
+    ] ?if ;
+
+: vocab-summary-path ( vocab -- string )
+    vocab-dir "summary.txt" append-path ;
+
+: vocab-summary ( vocab -- summary )
+    dup dup vocab-summary-path vocab-file-contents
+    [
+        vocab-name " vocabulary" append
+    ] [
+        nip first
+    ] if-empty ;
+
+M: vocab summary
+    [
+        dup vocab-summary %
+        " (" %
+        words>> assoc-size #
+        " words)" %
+    ] "" make ;
+
+M: vocab-link summary vocab-summary ;
+
+: set-vocab-summary ( string vocab -- )
+    [ 1array ] dip
+    dup vocab-summary-path
+    set-vocab-file-contents ;
+
+: vocab-tags-path ( vocab -- string )
+    vocab-dir "tags.txt" append-path ;
+
+: vocab-tags ( vocab -- tags )
+    dup vocab-tags-path vocab-file-contents harvest ;
+
+: set-vocab-tags ( tags vocab -- )
+    dup vocab-tags-path set-vocab-file-contents ;
+
+: add-vocab-tags ( tags vocab -- )
+    [ vocab-tags append prune ] keep set-vocab-tags ;
+
+: vocab-authors-path ( vocab -- string )
+    vocab-dir "authors.txt" append-path ;
+
+: vocab-authors ( vocab -- authors )
+    dup vocab-authors-path vocab-file-contents harvest ;
+
+: set-vocab-authors ( authors vocab -- )
+    dup vocab-authors-path set-vocab-file-contents ;
+
+: unportable? ( vocab -- ? )
+    vocab-tags "unportable" swap member? ;

basis/vocabs/metadata/summary.txt

@@ -0,0 +1 @@
+Managing vocabulary author, tag and summary information

basis/vocabs/refresh/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/vocabs/refresh/monitor/monitor-tests.factor

@@ -1,5 +1,5 @@
-USING: tools.test tools.vocabs.monitor io.pathnames ;
+USING: tools.test vocabs.refresh.monitor io.pathnames ;
-IN: tools.vocabs.monitor.tests
+IN: vocabs.refresh.monitor.tests
 
 [ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
 [ "kernel" ] [ "core/kernel/" path>vocab ] unit-test

basis/vocabs/refresh/monitor/monitor.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: threads io.files io.pathnames io.monitors init kernel
+USING: accessors assocs command-line concurrency.messaging
-vocabs vocabs.loader tools.vocabs namespaces continuations
+continuations init io.backend io.files io.monitors io.pathnames
-sequences splitting assocs command-line concurrency.messaging
+kernel namespaces sequences sets splitting threads
-io.backend sets tr accessors ;
+tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
-IN: tools.vocabs.monitor
+IN: vocabs.refresh.monitor
 
 TR: convert-separators "/\\" ".." ;
 
@@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ;
 [
     "-no-monitors" (command-line) member?
     [ start-monitor-thread ] unless
-] "tools.vocabs.monitor" add-init-hook
+] "vocabs.refresh.monitor" add-init-hook

basis/vocabs/refresh/refresh-docs.factor

@@ -0,0 +1,22 @@
+USING: help.markup help.syntax strings ;
+IN: vocabs.refresh
+
+HELP: source-modified?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ;
+
+HELP: refresh
+{ $values { "prefix" string } }
+{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
+
+HELP: refresh-all
+{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
+
+{ refresh refresh-all } related-words
+
+ARTICLE: "vocabs.refresh" "Runtime code reloading"
+"Reloading source files changed on disk:"
+{ $subsection refresh }
+{ $subsection refresh-all } ;
+
+ABOUT: "vocabs.refresh"

basis/vocabs/refresh/refresh.factor

@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs checksums checksums.crc32
+io.encodings.utf8 io.files kernel namespaces sequences sets
+source-files vocabs vocabs.errors vocabs.loader ;
+IN: vocabs.refresh
+
+: source-modified? ( path -- ? )
+    dup source-files get at [
+        dup path>>
+        dup exists? [
+            utf8 file-lines crc32 checksum-lines
+            swap checksum>> = not
+        ] [
+            2drop f
+        ] if
+    ] [
+        exists?
+    ] ?if ;
+
+SYMBOL: changed-vocabs
+
+: changed-vocab ( vocab -- )
+    dup vocab changed-vocabs get and
+    [ dup changed-vocabs get set-at ] [ drop ] if ;
+
+: unchanged-vocab ( vocab -- )
+    changed-vocabs get delete-at ;
+
+: unchanged-vocabs ( vocabs -- )
+    [ unchanged-vocab ] each ;
+
+: changed-vocab? ( vocab -- ? )
+    changed-vocabs get dup [ key? ] [ 2drop t ] if ;
+
+: filter-changed ( vocabs -- vocabs' )
+    [ changed-vocab? ] filter ;
+
+SYMBOL: modified-sources
+SYMBOL: modified-docs
+
+: (to-refresh) ( vocab variable loaded? path -- )
+    dup [
+        swap [
+            pick changed-vocab? [
+                source-modified? [ get push ] [ 2drop ] if
+            ] [ 3drop ] if
+        ] [ drop get push ] if
+    ] [ 2drop 2drop ] if ;
+
+: to-refresh ( prefix -- modified-sources modified-docs unchanged )
+    [
+        V{ } clone modified-sources set
+        V{ } clone modified-docs set
+
+        child-vocabs [
+            [
+                [
+                    [ modified-sources ]
+                    [ vocab source-loaded?>> ]
+                    [ vocab-source-path ]
+                    tri (to-refresh)
+                ] [
+                    [ modified-docs ]
+                    [ vocab docs-loaded?>> ]
+                    [ vocab-docs-path ]
+                    tri (to-refresh)
+                ] bi
+            ] each
+
+            modified-sources get
+            modified-docs get
+        ]
+        [ modified-docs get modified-sources get append diff ] bi
+    ] with-scope ;
+
+: do-refresh ( modified-sources modified-docs unchanged -- )
+    unchanged-vocabs
+    [
+        [ [ vocab f >>source-loaded? drop ] each ]
+        [ [ vocab f >>docs-loaded? drop ] each ] bi*
+    ]
+    [
+        append prune
+        [ unchanged-vocabs ]
+        [ require-all load-failures. ] bi
+    ] 2bi ;
+
+: refresh ( prefix -- ) to-refresh do-refresh ;
+
+: refresh-all ( -- ) "" refresh ;

basis/vocabs/refresh/summary.txt

@@ -0,0 +1 @@
+Reloading changed vocabularies from disk

basis/windows/errors/errors.factor

@@ -1,7 +1,7 @@
 USING: alien.c-types kernel locals math math.bitwise
 windows.kernel32 sequences byte-arrays unicode.categories
 io.encodings.string io.encodings.utf16n alien.strings
-arrays ;
+arrays literals ;
 IN: windows.errors
 
 CONSTANT: ERROR_SUCCESS                               0
@@ -732,11 +732,13 @@ ERROR: error-message-failed id ;
         win32-error-string throw
     ] when ;
 
-: expected-io-errors ( -- seq )
+CONSTANT: expected-io-errors
-    ERROR_SUCCESS
+    ${
-    ERROR_IO_INCOMPLETE
+        ERROR_SUCCESS
-    ERROR_IO_PENDING
+        ERROR_IO_INCOMPLETE
-    WAIT_TIMEOUT 4array ; foldable
+        ERROR_IO_PENDING
+        WAIT_TIMEOUT
+    }
 
 : expected-io-error? ( error-code -- ? )
     expected-io-errors member? ;

core/alien/strings/strings-docs.factor

@@ -0,0 +1,20 @@
+USING: help.markup help.syntax strings byte-arrays alien libc
+debugger io.encodings.string sequences ;
+IN: alien.strings
+
+HELP: string>alien
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
+{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
+
+HELP: alien>string
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
+{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
+
+HELP: string>symbol
+{ $values { "str" string } { "alien" alien } }
+{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
+$nl
+"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
+
+ABOUT: "c-strings"

core/alien/strings/strings.factor

@@ -0,0 +1,61 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays sequences kernel kernel.private accessors math
+alien.accessors byte-arrays io io.encodings io.encodings.utf8
+io.encodings.utf16n io.streams.byte-array io.streams.memory system
+system.private alien strings combinators namespaces init ;
+IN: alien.strings
+
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
+
+M: c-ptr alien>string
+    [ <memory-stream> ] [ <decoder> ] bi*
+    "\0" swap stream-read-until drop ;
+
+M: f alien>string
+    drop ;
+
+ERROR: invalid-c-string string ;
+
+: check-string ( string -- )
+    0 over memq? [ invalid-c-string ] [ drop ] if ;
+
+GENERIC# string>alien 1 ( string encoding -- byte-array )
+
+M: c-ptr string>alien drop ;
+
+M: string string>alien
+    over check-string
+    <byte-writer>
+    [ stream-write ]
+    [ 0 swap stream-write1 ]
+    [ stream>> >byte-array ]
+    tri ;
+
+HOOK: alien>native-string os ( alien -- string )
+
+HOOK: native-string>alien os ( string -- alien )
+
+M: windows alien>native-string utf16n alien>string ;
+
+M: wince native-string>alien utf16n string>alien ;
+
+M: winnt native-string>alien utf8 string>alien ;
+
+M: unix alien>native-string utf8 alien>string ;
+
+M: unix native-string>alien utf8 string>alien ;
+
+: dll-path ( dll -- string )
+    path>> alien>native-string ;
+
+: string>symbol ( str -- alien )
+    dup string?
+    [ native-string>alien ]
+    [ [ native-string>alien ] map ] if ;
+
+[
+    8 getenv utf8 alien>string string>cpu \ cpu set-global
+    9 getenv utf8 alien>string string>os \ os set-global
+] "alien.strings" add-init-hook
+

core/bootstrap/primitives.factor

@@ -82,8 +82,10 @@ bootstrapping? on
     "kernel"
     "kernel.private"
     "math"
+    "math.parser.private"
     "math.private"
     "memory"
+    "memory.private"
     "quotations"
     "quotations.private"
     "sbufs"
@@ -366,8 +368,8 @@ tuple
     { "float>bignum" "math.private" (( x -- y )) }
     { "fixnum>float" "math.private" (( x -- y )) }
     { "bignum>float" "math.private" (( x -- y )) }
-    { "string>float" "math.private" (( str -- n/f )) }
+    { "(string>float)" "math.parser.private" (( str -- n/f )) }
-    { "float>string" "math.private" (( n -- str )) }
+    { "(float>string)" "math.parser.private" (( n -- str )) }
     { "float>bits" "math" (( x -- n )) }
     { "double>bits" "math" (( x -- n )) }
     { "bits>float" "math" (( n -- x )) }
@@ -414,8 +416,8 @@ tuple
     { "(exists?)" "io.files.private" (( path -- ? )) }
     { "gc" "memory" (( -- )) }
     { "gc-stats" "memory" f }
-    { "save-image" "memory" (( path -- )) }
+    { "(save-image)" "memory.private" (( path -- )) }
-    { "save-image-and-exit" "memory" (( path -- )) }
+    { "(save-image-and-exit)" "memory.private" (( path -- )) }
     { "datastack" "kernel" (( -- ds )) }
     { "retainstack" "kernel" (( -- rs )) }
     { "callstack" "kernel" (( -- cs )) }
@@ -427,38 +429,38 @@ tuple
     { "code-room" "memory" (( -- code-free code-total )) }
     { "micros" "system" (( -- us )) }
     { "modify-code-heap" "compiler.units" (( alist -- )) }
-    { "dlopen" "alien.libraries" (( path -- dll )) }
+    { "(dlopen)" "alien.libraries" (( path -- dll )) }
-    { "dlsym" "alien.libraries" (( name dll -- alien )) }
+    { "(dlsym)" "alien.libraries" (( name dll -- alien )) }
     { "dlclose" "alien.libraries" (( dll -- )) }
     { "<byte-array>" "byte-arrays" (( n -- byte-array )) }
     { "(byte-array)" "byte-arrays" (( n -- byte-array )) }
     { "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) }
-    { "alien-signed-cell" "alien.accessors" f }
+    { "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-signed-cell" "alien.accessors" f }
+    { "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-unsigned-cell" "alien.accessors" f }
+    { "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-unsigned-cell" "alien.accessors" f }
+    { "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-signed-8" "alien.accessors" f }
+    { "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-signed-8" "alien.accessors" f }
+    { "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-unsigned-8" "alien.accessors" f }
+    { "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-unsigned-8" "alien.accessors" f }
+    { "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-signed-4" "alien.accessors" f }
+    { "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-signed-4" "alien.accessors" f }
+    { "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-unsigned-4" "alien.accessors" f }
+    { "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-unsigned-4" "alien.accessors" f }
+    { "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-signed-2" "alien.accessors" f }
+    { "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-signed-2" "alien.accessors" f }
+    { "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-unsigned-2" "alien.accessors" f }
+    { "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-unsigned-2" "alien.accessors" f }
+    { "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-signed-1" "alien.accessors" f }
+    { "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-signed-1" "alien.accessors" f }
+    { "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-unsigned-1" "alien.accessors" f }
+    { "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-unsigned-1" "alien.accessors" f }
+    { "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-float" "alien.accessors" f }
+    { "alien-float" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-float" "alien.accessors" f }
+    { "set-alien-float" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-double" "alien.accessors" f }
+    { "alien-double" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-double" "alien.accessors" f }
+    { "set-alien-double" "alien.accessors" (( value c-ptr n -- )) }
-    { "alien-cell" "alien.accessors" f }
+    { "alien-cell" "alien.accessors" (( c-ptr n -- value )) }
-    { "set-alien-cell" "alien.accessors" f }
+    { "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) }
     { "alien-address" "alien" (( c-ptr -- addr )) }
     { "set-slot" "slots.private" (( value obj n -- )) }
     { "string-nth" "strings.private" (( n string -- ch )) }
@@ -472,7 +474,7 @@ tuple
     { "end-scan" "memory" (( -- )) }
     { "size" "memory" (( obj -- n )) }
     { "die" "kernel" (( -- )) }
-    { "fopen" "io.streams.c" (( path mode -- alien )) }
+    { "(fopen)" "io.streams.c" (( path mode -- alien )) }
     { "fgetc" "io.streams.c" (( alien -- ch/f )) }
     { "fread" "io.streams.c" (( n alien -- str/f )) }
     { "fputc" "io.streams.c" (( ch alien -- )) }

core/bootstrap/syntax.factor

@@ -16,6 +16,7 @@ IN: bootstrap.syntax
     "<PRIVATE"
     "BIN:"
     "B{"
+    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"

core/byte-vectors/byte-vectors.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays accessors parser
+sequences.private growable byte-arrays accessors ;
-prettyprint.custom ;
 IN: byte-vectors
 
 TUPLE: byte-vector
@@ -42,10 +41,4 @@ M: byte-array like
 
 M: byte-array new-resizable drop <byte-vector> ;
 
-SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;
-
-M: byte-vector pprint* pprint-object ;
-M: byte-vector pprint-delims drop \ BV{ \ } ;
-M: byte-vector >pprint-sequence ;
-
 INSTANCE: byte-vector growable

core/classes/algebra/algebra-tests.factor

@@ -305,7 +305,16 @@ SINGLETON: sc
 
 [ sa ] [ sa { sa sb sc } min-class ] unit-test
 
+[ f ] [ sa sb classes-intersect? ] unit-test
+
 [ +lt+ ] [ integer sequence class<=> ] unit-test
 [ +lt+ ] [ sequence object class<=> ] unit-test
 [ +gt+ ] [ object sequence class<=> ] unit-test
 [ +eq+ ] [ integer integer class<=> ] unit-test
+
+! Limitations:
+
+! UNION: u1 sa sb ;
+! UNION: u2 sc ;
+
+! [ f ] [ u1 u2 classes-intersect? ] unit-test

core/generic/standard/standard.factor

@@ -44,7 +44,7 @@ M: standard-combination inline-cache-quot ( word methods -- )
     #! Direct calls to the generic word (not tail calls or indirect calls)
     #! will jump to the inline cache entry point instead of the megamorphic
     #! dispatch entry point.
-    combination get #>> [ f inline-cache-miss ] 3curry [ ] like ;
+    combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
 
 : make-empty-cache ( -- array )
     mega-cache-size get f <array> ;