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/cocoa/cocoa.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
@@ -27,22 +27,16 @@ SYMBOL: frameworks
 
 frameworks [ V{ } clone ] initialize
 
-[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
 
 SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 
 SYNTAX: IMPORT: scan [ ] import-objc-class ;
 
-"Compiling Objective C bridge..." print
+"Importing Cocoa classes..." print
 
 "cocoa.classes" create-vocab drop
 
-{
-    "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} [ words ] map concat compile
-
-"Importing Cocoa classes..." print
-
 [
     {
         "NSApplication"

basis/cocoa/views/views-docs.factor

@@ -1,13 +1,9 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup ui.pixel-formats ;
 IN: cocoa.views
 
-HELP: <PixelFormat>
-{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
-{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
-
 HELP: <GLView>
-{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } }
+{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } }
-{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ;
+{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ;
 
 HELP: view-dim
 { $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } }
@@ -18,7 +14,6 @@ HELP: mouse-location
 { $description "Outputs the current mouse location." } ;
 
 ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
-{ $subsection <PixelFormat> }
 { $subsection <GLView> }
 { $subsection view-dim }
 { $subsection mouse-location } ;

basis/cocoa/views/views.factor

@@ -42,39 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
 CONSTANT: NSOpenGLPFAVirtualScreenCount 128
 CONSTANT: NSOpenGLCPSwapInterval 222
 
-<PRIVATE
+: <GLView> ( class dim pixel-format -- view )
-
+    [ -> alloc ]
-SYMBOL: software-renderer?
+    [ [ 0 0 ] dip first2 <CGRect> ]
-SYMBOL: multisample?
+    [ handle>> ] tri*
-
-PRIVATE>
-
-: with-software-renderer ( quot -- )
-    [ t software-renderer? ] dip with-variable ; inline
-
-: with-multisample ( quot -- )
-    [ t multisample? ] dip with-variable ; inline
-
-: <PixelFormat> ( attributes -- pixelfmt )
-    NSOpenGLPixelFormat -> alloc swap [
-        %
-        NSOpenGLPFADepthSize , 16 ,
-        software-renderer? get [
-            NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
-        ] when
-        multisample? get [
-            NSOpenGLPFASupersample ,
-            NSOpenGLPFASampleBuffers , 1 ,
-            NSOpenGLPFASamples , 8 ,
-        ] when
-        0 ,
-    ] int-array{ } make
-    -> initWithAttributes:
-    -> autorelease ;
-
-: <GLView> ( class dim -- view )
-    [ -> alloc 0 0 ] dip first2 <CGRect>
-    NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
     -> initWithFrame:pixelFormat:
     dup 1 -> setPostsBoundsChangedNotifications:
     dup 1 -> setPostsFrameChangedNotifications: ;

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/codegen/codegen.factor

@@ -3,7 +3,7 @@
 USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays alien.complex sets libc alien.libraries
+alien.strings alien.arrays alien.complex alien.libraries sets libc
 continuations.private fry cpu.architecture
 source-files.errors
 compiler.errors

basis/compiler/compiler.factor

@@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
     } cond ;
 
 : optimize? ( word -- ? )
-    {
+    { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
-        [ predicate-engine-word? ]
+
-        [ contains-breakpoints? ]
+: contains-breakpoints? ( -- ? )
-        [ single-generic? ]
+    dependencies get keys [ "break?" word-prop ] any? ;
-    } 1|| not ;
 
 : frontend ( word -- nodes )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
-    dup optimize?
+    dup optimize? [
-    [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
+        [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-    [ dup def>> deoptimize-with ]
+        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
-    if ;
+    ] [ dup def>> deoptimize-with ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.

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/compiler/tree/builder/builder.factor

@@ -65,5 +65,3 @@ PRIVATE>
         ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
     ] with-variable ;
 
-: contains-breakpoints? ( word -- ? )
-    def>> [ word? ] filter [ "break?" word-prop ] any? ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -157,11 +157,7 @@ DEFER: (flat-length)
     ] sum-outputs ;
 
 : should-inline? ( #call word -- ? )
-    {
+    dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
-        { [ dup contains-breakpoints? ] [ 2drop f ] }
-        { [ dup "inline" word-prop ] [ 2drop t ] }
-        [ inlining-rank 5 >= ]
-    } cond ;
 
 SYMBOL: history
 

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/delegate/delegate-docs.factor

@@ -24,7 +24,7 @@ HELP: CONSULT:
 
 HELP: SLOT-PROTOCOL:
 { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
-{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ;
 
 { define-protocol POSTPONE: PROTOCOL: } related-words
 

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/functors/functors-tests.factor

@@ -81,7 +81,26 @@ SYMBOL: W
 
 [ blorgh ] [ blorgh ] unit-test
 
-GENERIC: some-generic ( a -- b )
+<<
+
+FUNCTOR: generic-test ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+GENERIC: W ( a -- b )
+M: object W ;
+M: integer W 1 + ;
+
+;FUNCTOR
+
+"snurv" generic-test
+
+>>
+
+[ 2   ] [ 1   snurv ] unit-test
+[ 3.0 ] [ 3.0 snurv ] unit-test
 
 ! Does replacing an ordinary word with a functor-generated one work?
 [ [ ] ] [
@@ -89,6 +108,7 @@ GENERIC: some-generic ( a -- b )
 
     TUPLE: some-tuple ;
     : some-word ( -- ) ;
+    GENERIC: some-generic ( a -- b )
     M: some-tuple some-generic ;
     SYMBOL: some-symbol
     "> <string-reader> "functors-test" parse-stream
@@ -97,6 +117,7 @@ GENERIC: some-generic ( a -- b )
 : test-redefinition ( -- )
     [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
     [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
+    [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
     [ t ] [
         "some-tuple" "functors.tests" lookup
         "some-generic" "functors.tests" lookup method >boolean
@@ -109,13 +130,14 @@ FUNCTOR: redefine-test ( W -- )
 
 W-word DEFINES ${W}-word
 W-tuple DEFINES-CLASS ${W}-tuple
-W-generic IS ${W}-generic
+W-generic DEFINES ${W}-generic
 W-symbol DEFINES ${W}-symbol
 
 WHERE
 
 TUPLE: W-tuple ;
 : W-word ( -- ) ;
+GENERIC: W-generic ( a -- b )
 M: W-tuple W-generic ;
 SYMBOL: W-symbol
 

basis/functors/functors.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel quotations classes.tuple make combinators generic
+USING: accessors arrays classes.mixin classes.parser
-words interpolate namespaces sequences io.streams.string fry
+classes.tuple classes.tuple.parser combinators effects
-classes.mixin effects lexer parser classes.tuple.parser
+effects.parser fry generic generic.parser generic.standard
-effects.parser locals.types locals.parser generic.parser
+interpolate io.streams.string kernel lexer locals.parser
-locals.rewrite.closures vocabs.parser classes.parser
+locals.rewrite.closures locals.types make namespaces parser
-arrays accessors words.symbol ;
+quotations sequences vocabs.parser words words.symbol ;
 IN: functors
 
 ! This is a hack
@@ -18,6 +18,8 @@ IN: functors
 
 : define-declared* ( word def effect -- ) pick set-word define-declared ;
 
+: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+
 TUPLE: fake-call-next-method ;
 
 TUPLE: fake-quotation seq ;
@@ -104,6 +106,11 @@ SYNTAX: `INSTANCE:
     scan-param parsed
     \ add-mixin-instance parsed ;
 
+SYNTAX: `GENERIC:
+    scan-param parsed
+    complete-effect parsed
+    \ define-simple-generic* parsed ;
+
 SYNTAX: `inline [ word make-inline ] over push-all ;
 
 SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
@@ -130,6 +137,7 @@ DEFER: ;FUNCTOR delimiter
         { "M:" POSTPONE: `M: }
         { "C:" POSTPONE: `C: }
         { ":" POSTPONE: `: }
+        { "GENERIC:" POSTPONE: `GENERIC: }
         { "INSTANCE:" POSTPONE: `INSTANCE: }
         { "SYNTAX:" POSTPONE: `SYNTAX: }
         { "SYMBOL:" POSTPONE: `SYMBOL: }

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
@@ -87,7 +87,7 @@ PRIVATE>
 
 : help-lint-all ( -- ) "" help-lint ;
 
-: :lint-failures ( -- ) lint-failures get errors. ;
+: :lint-failures ( -- ) lint-failures get values errors. ;
 
 : unlinked-words ( words -- seq )
     all-word-help [ article-parent not ] filter ;

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/inverse/inverse-tests.factor

@@ -1,5 +1,7 @@
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
 USING: inverse tools.test arrays math kernel sequences
-math.functions math.constants continuations ;
+math.functions math.constants continuations combinators.smart ;
 IN: inverse-tests
 
 [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@@ -69,7 +71,7 @@ C: <nil> nil
 
 [ t ] [ pi [ pi ] matches? ] unit-test
 [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
-[ ] [ 3 [ _ ] undo ] unit-test
+[ ] [ 3 [ __ ] undo ] unit-test
 
 [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
 [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
@@ -88,4 +90,7 @@ TUPLE: funny-tuple ;
 : <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
 : funny-tuple ( -- ) "OOPS" throw ;
 
-[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+
+[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test

basis/inverse/inverse.factor

@@ -1,12 +1,12 @@
-! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel words summary slots quotations
 sequences assocs math arrays stack-checker effects generalizations
 continuations debugger classes.tuple namespaces make vectors
 bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting
+sequences.private combinators mirrors splitting combinators.smart
-combinators.short-circuit fry words.symbol generalizations ;
+combinators.short-circuit fry words.symbol generalizations
-RENAME: _ fry => __
+classes ;
 IN: inverse
 
 ERROR: fail ;
@@ -14,7 +14,7 @@ M: fail summary drop "Matching failed" ;
 
 : assure ( ? -- ) [ fail ] unless ; inline
 
-: =/fail ( obj1 obj2 -- ) = assure ;
+: =/fail ( obj1 obj2 -- ) = assure ; inline
 
 ! Inverse of a quotation
 
@@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
 \ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
+\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
+\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
+\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
+\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
+
 \ not define-involution
-\ >boolean [ { t f } memq? assure ] define-inverse
+\ >boolean [ dup { t f } memq? assure ] define-inverse
 
 \ tuple>array \ >tuple define-dual
 \ reverse define-involution
 
-\ undo 1 [ [ call ] curry ] define-pop-inverse
+\ undo 1 [ ] define-pop-inverse
-\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
+\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
 
 \ exp \ log define-dual
 \ sq \ sqrt define-dual
@@ -173,16 +178,13 @@ ERROR: missing-literal ;
     2curry
 ] define-pop-inverse
 
-DEFER: _
+DEFER: __
-\ _ [ drop ] define-inverse
+\ __ [ drop ] define-inverse
 
 : both ( object object -- object )
     dupd assert= ;
 \ both [ dup ] define-inverse
 
-: assure-length ( seq length -- seq )
-    over length =/fail ;
-
 {
     { >array array? }
     { >vector vector? }
@@ -194,14 +196,23 @@ DEFER: _
     { >string string? }
     { >sbuf sbuf? }
     { >quotation quotation? }
-} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
+} [ '[ dup _ execute assure ] define-inverse ] assoc-each
 
-! These actually work on all seqs--should they?
+: assure-length ( seq length -- )
-\ 1array [ 1 assure-length first ] define-inverse
+    swap length =/fail ; inline
-\ 2array [ 2 assure-length first2 ] define-inverse
+
-\ 3array [ 3 assure-length first3 ] define-inverse
+: assure-array ( array -- array )
-\ 4array [ 4 assure-length first4 ] define-inverse
+    dup array? assure ; inline
-\ narray 1 [ [ firstn ] curry ] define-pop-inverse
+
+: undo-narray ( array n -- ... )
+    [ assure-array ] dip
+    [ assure-length ] [ firstn ] 2bi ; inline
+
+\ 1array [ 1 undo-narray ] define-inverse
+\ 2array [ 2 undo-narray ] define-inverse
+\ 3array [ 3 undo-narray ] define-inverse
+\ 4array [ 4 undo-narray ] define-inverse
+\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
 
 \ first [ 1array ] define-inverse
 \ first2 [ 2array ] define-inverse
@@ -214,6 +225,12 @@ DEFER: _
 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
 \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
 
+: assure-same-class ( obj1 obj2 -- )
+    [ class ] bi@ = assure ; inline
+
+\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
+\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
+
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
     "predicate" word-prop [ dupd call assure ] curry ;
@@ -245,7 +262,7 @@ DEFER: _
     ] recover ; inline
 
 : true-out ( quot effect -- quot' )
-    out>> '[ @ __ ndrop t ] ;
+    out>> '[ @ _ ndrop t ] ;
 
 : false-recover ( effect -- quot )
     in>> [ ndrop f ] curry [ recover-fail ] curry ;

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/math/rectangles/rectangles-tests.factor

@@ -1,42 +1,42 @@
 USING: tools.test math.rectangles ;
 IN: math.rectangles.tests
 
-[ T{ rect f { 10 10 } { 20 20 } } ]
+[ RECT: { 10 10 } { 20 20 } ]
 [
-    T{ rect f { 10 10 } { 50 50 } }
+    RECT: { 10 10 } { 50 50 }
-    T{ rect f { -10 -10 } { 40 40 } }
+    RECT: { -10 -10 } { 40 40 }
     rect-intersect
 ] unit-test
 
-[ T{ rect f { 200 200 } { 0 0 } } ]
+[ RECT: { 200 200 } { 0 0 } ]
 [
-    T{ rect f { 100 100 } { 50 50 } }
+    RECT: { 100 100 } { 50 50 }
-    T{ rect f { 200 200 } { 40 40 } }
+    RECT: { 200 200 } { 40 40 }
     rect-intersect
 ] unit-test
 
 [ f ] [
-    T{ rect f { 100 100 } { 50 50 } }
+    RECT: { 100 100 } { 50 50 }
-    T{ rect f { 200 200 } { 40 40 } }
+    RECT: { 200 200 } { 40 40 }
     contains-rect?
 ] unit-test
 
 [ t ] [
-    T{ rect f { 100 100 } { 50 50 } }
+    RECT: { 100 100 } { 50 50 }
-    T{ rect f { 120 120 } { 40 40 } }
+    RECT: { 120 120 } { 40 40 }
     contains-rect?
 ] unit-test
 
 [ f ] [
-    T{ rect f { 1000 100 } { 50 50 } }
+    RECT: { 1000 100 } { 50 50 }
-    T{ rect f { 120 120 } { 40 40 } }
+    RECT: { 120 120 } { 40 40 }
     contains-rect?
 ] unit-test
 
-[ T{ rect f { 10 20 } { 20 20 } } ] [
+[ RECT: { 10 20 } { 20 20 } ] [
     {
         { 20 20 }
         { 10 40 }
         { 30 30 }
     } rect-containing
-] unit-test
+] unit-test

basis/math/rectangles/rectangles.factor

@@ -1,12 +1,18 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.vectors accessors ;
+USING: kernel arrays sequences math math.vectors accessors
+parser prettyprint.custom prettyprint.backend ;
 IN: math.rectangles
 
 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
 
 : <rect> ( loc dim -- rect ) rect boa ; inline
 
+SYNTAX: RECT: scan-object scan-object <rect> parsed ;
+
+M: rect pprint*
+    \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
 : <zero-rect> ( -- rect ) rect new ; inline
 
 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@@ -55,4 +61,4 @@ M: rect contains-point?
 : set-rect-bounds ( rect1 rect -- )
     [ [ loc>> ] dip (>>loc) ]
     [ [ dim>> ] dip (>>dim) ]
-    2bi ; inline
+    2bi ; inline

basis/opengl/gl/windows/windows.factor

@@ -1,6 +1,11 @@
-USING: kernel windows.opengl32 ;
+USING: alien.syntax kernel windows.types ;
 IN: opengl.gl.windows
 
+LIBRARY: gl
+
+FUNCTION: HGLRC wglGetCurrentContext ( ) ;
+FUNCTION: void* wglGetProcAddress ( char* name ) ;
+
 : gl-function-context ( -- context ) wglGetCurrentContext ; inline
 : gl-function-address ( name -- address ) wglGetProcAddress ; inline
 : gl-function-calling-convention ( -- str ) "stdcall" ; inline

basis/opengl/shaders/shaders.factor

@@ -92,11 +92,16 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
 : gl-program-shaders-length ( program -- shaders-length )
     GL_ATTACHED_SHADERS gl-program-get-int ; inline
 
+! On some macosx-x86-64 graphics drivers, glGetAttachedShaders tries to treat the
+! shaders parameter as a ulonglong array rather than a GLuint array as documented.
+! We hack around this by allocating a buffer twice the size and sifting out the zero
+! values
+
 : gl-program-shaders ( program -- shaders )
-    dup gl-program-shaders-length
+    dup gl-program-shaders-length 2 *
     0 <int>
     over <uint-array>
-    [ glGetAttachedShaders ] keep ;
+    [ glGetAttachedShaders ] keep [ zero? not ] filter ;
 
 : delete-gl-program-only ( program -- )
     glDeleteProgram ; inline

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 vocabs.hierarchy 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/random/random.factor

@@ -54,7 +54,7 @@ PRIVATE>
 
 : randomize ( seq -- seq )
     dup length [ dup 1 > ]
-    [ [ random ] [ 1- ] bi [ pick exchange ] keep ]
+    [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
     while drop ;
 
 : delete-random ( seq -- elt )

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
 
@@ -651,7 +651,7 @@ M: object infer-call*
 
 \ become { array array } { } define-primitive
 
-\ innermost-frame-quot { callstack } { quotation } define-primitive
+\ innermost-frame-executing { callstack } { object } define-primitive
 
 \ innermost-frame-scan { callstack } { fixnum } 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/continuations/continuations.factor

@@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
 sequences.private assocs models models.arrow arrays accessors
-generic generic.single definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref fry ;
 IN: tools.continuations
 
 <PRIVATE
@@ -79,21 +79,18 @@ M: object add-breakpoint ;
     (step-into-call-next-method)
 } [ t "no-compile" set-word-prop ] each >>
 
+: >innermost-frame< ( callstack -- n quot )
+    [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
+
+: (change-frame) ( callstack quot -- callstack' )
+    [ dup innermost-frame-executing quotation? ] dip '[
+        clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
+    ] when ; inline
+
 : change-frame ( continuation quot -- continuation' )
     #! Applies quot to innermost call frame of the
     #! continuation.
-    [ clone ] dip [
+    [ clone ] dip '[ _ (change-frame) ] change-call ; inline
-        [ clone ] dip
-        [
-            [
-                [ innermost-frame-scan 1+ ]
-                [ innermost-frame-quot ] bi
-            ] dip call
-        ]
-        [ drop set-innermost-frame-quot ]
-        [ drop ]
-        2tri
-    ] curry change-call ; inline
 
 PRIVATE>
 
@@ -101,7 +98,7 @@ PRIVATE>
     [
         2dup length = [ nip [ break ] append ] [
             2dup nth \ break = [ nip ] [
-                swap 1+ cut [ break ] glue 
+                swap 1 + cut [ break ] glue 
             ] if
         ] if
     ] change-frame ;
@@ -109,7 +106,6 @@ PRIVATE>
 : continuation-step-out ( continuation -- continuation' )
     [ nip \ break suffix ] change-frame ;
 
-
 {
     { call [ (step-into-quot) ] }
     { dip [ (step-into-dip) ] }
@@ -124,7 +120,7 @@ PRIVATE>
 
 ! Never step into these words
 : don't-step-into ( word -- )
-    dup [ execute break ] curry "step-into" set-word-prop ;
+    dup '[ _ execute break ] "step-into" set-word-prop ;
 
 {
     >n ndrop >c c>
@@ -151,6 +147,4 @@ PRIVATE>
     ] change-frame ;
 
 : continuation-current ( continuation -- obj )
-    call>>
+    call>> >innermost-frame< ?nth ;
-    [ innermost-frame-scan 1+ ]
-    [ innermost-frame-quot ] bi ?nth ;

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 ( -- )
@@ -346,13 +346,6 @@ IN: tools.deploy.shaker
 : compress-wrappers ( -- )
     [ wrapper? ] [ ] "wrappers" compress ;
 
-: finish-deploy ( final-image -- )
-    "Finishing up" show
-    V{ } set-namestack
-    V{ } set-catchstack
-    "Saving final image" show
-    save-image-and-exit ;
-
 SYMBOL: deploy-vocab
 
 : [:c] ( -- word ) ":c" "debugger" lookup ;
@@ -437,7 +430,8 @@ SYMBOL: deploy-vocab
                 "Vocabulary has no MAIN: word." print flush 1 exit
             ] unless
             strip
-            finish-deploy
+            "Saving final image" show
+            save-image-and-exit
         ] deploy-error-handler
     ] bind ;
 

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.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/tools/walker/walker-tests.factor

@@ -2,7 +2,7 @@ USING: tools.walker io io.streams.string kernel math
 math.private namespaces prettyprint sequences tools.test
 continuations math.parser threads arrays tools.walker.debug
 generic.single sequences.private kernel.private
-tools.continuations accessors words ;
+tools.continuations accessors words combinators ;
 IN: tools.walker.tests
 
 [ { } ] [
@@ -131,4 +131,18 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
 \ method-breakpoint-test don't-step-into
 
 [ { 3 } ]
-[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+
+: case-breakpoint-test ( -- x )
+    5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
+
+: call(-breakpoint-test ( -- x )
+    [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test

basis/ui/backend/cocoa/cocoa.factor

@@ -1,14 +1,16 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays assocs cocoa cocoa.application
+USING: accessors alien.c-types arrays assocs classes cocoa
-command-line kernel memory namespaces cocoa.messages
+cocoa.application cocoa.classes cocoa.messages cocoa.nibs
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
+cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
-cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private
+cocoa.views cocoa.windows combinators command-line
-ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+core-foundation core-foundation.run-loop core-graphics
-ui.backend.cocoa.views core-foundation core-foundation.run-loop
+core-graphics.types destructors fry generalizations io.thread
-core-graphics.types threads math.rectangles fry libc
+kernel libc literals locals math math.rectangles memory
-generalizations alien.c-types cocoa.views
+namespaces sequences specialized-arrays.int threads ui
-combinators io.thread locals ;
+ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
+ui.private words.symbol ;
 IN: ui.backend.cocoa
 
 TUPLE: handle ;
@@ -20,6 +22,42 @@ C: <offscreen-handle> offscreen-handle
 
 SINGLETON: cocoa-ui-backend
 
+PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
+    { double-buffered { $ NSOpenGLPFADoubleBuffer } }
+    { stereo { $ NSOpenGLPFAStereo } }
+    { offscreen { $ NSOpenGLPFAOffScreen } }
+    { fullscreen { $ NSOpenGLPFAFullScreen } }
+    { windowed { $ NSOpenGLPFAWindow } }
+    { accelerated { $ NSOpenGLPFAAccelerated } }
+    { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
+    { backing-store { $ NSOpenGLPFABackingStore } }
+    { multisampled { $ NSOpenGLPFAMultisample } }
+    { supersampled { $ NSOpenGLPFASupersample } }
+    { sample-alpha { $ NSOpenGLPFASampleAlpha } }
+    { color-float { $ NSOpenGLPFAColorFloat } }
+    { color-bits { $ NSOpenGLPFAColorSize } }
+    { alpha-bits { $ NSOpenGLPFAAlphaSize } }
+    { accum-bits { $ NSOpenGLPFAAccumSize } }
+    { depth-bits { $ NSOpenGLPFADepthSize } }
+    { stencil-bits { $ NSOpenGLPFAStencilSize } }
+    { aux-buffers { $ NSOpenGLPFAAuxBuffers } }
+    { sample-buffers { $ NSOpenGLPFASampleBuffers } }
+    { samples { $ NSOpenGLPFASamples } }
+}
+
+M: cocoa-ui-backend (make-pixel-format)
+    nip >NSOpenGLPFA-int-array
+    NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ;
+
+M: cocoa-ui-backend (free-pixel-format)
+    handle>> -> release ;
+
+M: cocoa-ui-backend (pixel-format-attribute)
+    [ handle>> ] [ >NSOpenGLPFA ] bi*
+    [ drop f ]
+    [ first 0 <int> [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ]
+    if-empty ;
+
 TUPLE: pasteboard handle ;
 
 C: <pasteboard> pasteboard
@@ -70,7 +108,8 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
     handle>> view>> -> isInFullScreenMode zero? not ;
 
 M:: cocoa-ui-backend (open-window) ( world -- )
-    world dim>> <FactorView> :> view
+    world [ [ dim>> ] dip <FactorView> ]
+    with-world-pixel-format :> view
     view world world>NSRect <ViewWindow> :> window
     view -> release
     world view register-window
@@ -97,18 +136,19 @@ M: cocoa-ui-backend raise-window* ( world -- )
     ] when* ;
 
 : pixel-size ( pixel-format -- size )
-    0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+    color-bits pixel-format-attribute -3 shift ;
-    keep *int -3 shift ;
 
 : offscreen-buffer ( world pixel-format -- alien w h pitch )
     [ dim>> first2 ] [ pixel-size ] bi*
     { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
 
-: gadget-offscreen-context ( world -- context buffer )
+:: gadget-offscreen-context ( world -- context buffer )
-    NSOpenGLPFAOffScreen 1array <PixelFormat>
+    world [
-    [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
+        nip :> pf
-    [ offscreen-buffer ] 2bi
+        NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext:
-    4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+        dup world pf offscreen-buffer
+        4 npick [ -> setOffScreen:width:height:rowbytes: ] dip
+    ] with-world-pixel-format ;
 
 M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
     dup gadget-offscreen-context <offscreen-handle> >>handle drop ;

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
@@ -365,8 +365,8 @@ CLASS: {
     -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
     CGLSetParameter drop ;
 
-: <FactorView> ( dim -- view )
+: <FactorView> ( dim pixel-format -- view )
-    FactorView swap <GLView> [ sync-refresh-to-screen ] keep ;
+    [ FactorView ] 2dip <GLView> [ sync-refresh-to-screen ] keep ;
 
 : save-position ( world window -- )
     -> frame CGRect-top-left 2array >>window-loc drop ;

basis/ui/backend/windows/windows.factor

@@ -10,11 +10,161 @@ windows.messages windows.types windows.offscreen windows.nt
 threads libc combinators fry combinators.short-circuit continuations
 command-line shuffle opengl ui.render ascii math.bitwise locals
 accessors math.rectangles math.order ascii calendar
-io.encodings.utf16n windows.errors ;
+io.encodings.utf16n windows.errors literals ui.pixel-formats 
+ui.pixel-formats.private memoize classes ;
 IN: ui.backend.windows
 
 SINGLETON: windows-ui-backend
 
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
+C: <win> win
+C: <win-offscreen> win-offscreen
+
+<PRIVATE
+
+PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
+    { double-buffered { $ WGL_DOUBLE_BUFFER_ARB 1 } }
+    { stereo { $ WGL_STEREO_ARB 1 } }
+    { offscreen { $ WGL_DRAW_TO_BITMAP_ARB 1 } }
+    { fullscreen { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
+    { windowed { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
+    { accelerated { $ WGL_ACCELERATION_ARB $ WGL_FULL_ACCELERATION_ARB } }
+    { software-rendered { $ WGL_ACCELERATION_ARB $ WGL_NO_ACCELERATION_ARB } }
+    { backing-store { $ WGL_SWAP_METHOD_ARB $ WGL_SWAP_COPY_ARB } }
+    { color-float { $ WGL_TYPE_RGBA_FLOAT_ARB 1 } }
+    { color-bits { $ WGL_COLOR_BITS_ARB } }
+    { red-bits { $ WGL_RED_BITS_ARB } }
+    { green-bits { $ WGL_GREEN_BITS_ARB } }
+    { blue-bits { $ WGL_BLUE_BITS_ARB } }
+    { alpha-bits { $ WGL_ALPHA_BITS_ARB } }
+    { accum-bits { $ WGL_ACCUM_BITS_ARB } }
+    { accum-red-bits { $ WGL_ACCUM_RED_BITS_ARB } }
+    { accum-green-bits { $ WGL_ACCUM_GREEN_BITS_ARB } }
+    { accum-blue-bits { $ WGL_ACCUM_BLUE_BITS_ARB } }
+    { accum-alpha-bits { $ WGL_ACCUM_ALPHA_BITS_ARB } }
+    { depth-bits { $ WGL_DEPTH_BITS_ARB } }
+    { stencil-bits { $ WGL_STENCIL_BITS_ARB } }
+    { aux-buffers { $ WGL_AUX_BUFFERS_ARB } }
+    { sample-buffers { $ WGL_SAMPLE_BUFFERS_ARB } }
+    { samples { $ WGL_SAMPLES_ARB } }
+}
+
+MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? )
+    { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
+: has-wglChoosePixelFormatARB? ( world -- ? )
+    handle>> hDC>> (has-wglChoosePixelFormatARB?) ;
+
+: arb-make-pixel-format ( world attributes -- pf )
+    [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
+    [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
+
+: arb-pixel-format-attribute ( pixel-format attribute -- value )
+    >WGL_ARB
+    [ drop f ] [
+        [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
+        first <int> 0 <int>
+        [ wglGetPixelFormatAttribivARB win32-error=0/f ]
+        keep *int
+    ] if-empty ;
+
+CONSTANT: pfd-flag-map H{
+    { double-buffered $ PFD_DOUBLEBUFFER }
+    { stereo $ PFD_STEREO }
+    { offscreen $ PFD_DRAW_TO_BITMAP }
+    { fullscreen $ PFD_DRAW_TO_WINDOW }
+    { windowed $ PFD_DRAW_TO_WINDOW }
+    { backing-store $ PFD_SWAP_COPY }
+    { software-rendered $ PFD_GENERIC_FORMAT }
+}
+
+: >pfd-flag ( attribute -- value )
+    pfd-flag-map at [ ] [ 0 ] if* ;
+
+: >pfd-flags ( attributes -- flags )
+    [ >pfd-flag ] [ bitor ] map-reduce
+    PFD_SUPPORT_OPENGL bitor ;
+
+: attr-value ( attributes name -- value )
+    [ instance? ] curry find nip
+    [ value>> ] [ 0 ] if* ;
+
+: >pfd ( attributes -- pfd )
+    "PIXELFORMATDESCRIPTOR" <c-object>
+    "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
+    1 over set-PIXELFORMATDESCRIPTOR-nVersion
+    over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags
+    PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
+    over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits
+    over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits
+    over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits
+    over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits
+    over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits
+    over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits
+    over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits
+    over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits
+    over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits
+    over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits
+    over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits
+    over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits
+    over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers
+    PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask
+    nip ;
+
+: pfd-make-pixel-format ( world attributes -- pf )
+    [ handle>> hDC>> ] [ >pfd ] bi*
+    ChoosePixelFormat dup win32-error=0/f ;
+
+: get-pfd ( pixel-format -- pfd )
+    [ world>> handle>> hDC>> ] [ handle>> ] bi
+    "PIXELFORMATDESCRIPTOR" heap-size
+    "PIXELFORMATDESCRIPTOR" <c-object>
+    [ DescribePixelFormat win32-error=0/f ] keep ;
+
+: pfd-flag? ( pfd flag -- ? )
+    [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ;
+
+: (pfd-pixel-format-attribute) ( pfd attribute -- value )
+    {
+        { double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] }
+        { stereo [ PFD_STEREO pfd-flag? ] }
+        { offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] }
+        { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
+        { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
+        { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
+        { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] }
+        { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] }
+        { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] }
+        { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] }
+        { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] }
+        { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] }
+        { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] }
+        { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] }
+        { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] }
+        { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] }
+        { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] }
+        { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] }
+        { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] }
+        [ 2drop f ]
+    } case ;
+
+: pfd-pixel-format-attribute ( pixel-format attribute -- value )
+    [ get-pfd ] dip (pfd-pixel-format-attribute) ;
+
+M: windows-ui-backend (make-pixel-format)
+    over has-wglChoosePixelFormatARB?
+    [ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ;
+
+M: windows-ui-backend (free-pixel-format)
+    drop ;
+
+M: windows-ui-backend (pixel-format-attribute)
+    over world>> has-wglChoosePixelFormatARB?
+    [ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
+
+PRIVATE>
+
 : lo-word ( wparam -- lo ) <short> *short ; inline
 : hi-word ( wparam -- hi ) -16 shift lo-word ; inline
 : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
@@ -73,12 +223,6 @@ M: pasteboard set-clipboard-contents drop copy ;
     <pasteboard> clipboard set-global
     <clipboard> selection set-global ;
 
-TUPLE: win-base hDC hRC ;
-TUPLE: win < win-base hWnd world title ;
-TUPLE: win-offscreen < win-base hBitmap bits ;
-C: <win> win
-C: <win-offscreen> win-offscreen
-
 SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 
 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
@@ -477,25 +621,24 @@ M: windows-ui-backend do-events
     f class-name-ptr set-global
     f msg-obj set-global ;
 
-: setup-pixel-format ( hdc flags -- )
+: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
-    32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
-    swapd SetPixelFormat win32-error=0/f ;
 
-: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
+: get-rc ( world -- )
+    handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
+    [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
 
-: get-rc ( hDC -- hRC )
+: set-pixel-format ( pixel-format hdc -- )
-    dup wglCreateContext dup win32-error=0/f
+    swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
-    [ wglMakeCurrent win32-error=0/f ] keep ;
 
-: setup-gl ( hwnd -- hDC hRC )
+: setup-gl ( world -- )
-    get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
+    [ get-dc ] keep
+    [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
+    with-world-pixel-format ;
 
 M: windows-ui-backend (open-window) ( world -- )
-    [ create-window [ setup-gl ] keep ] keep
+    [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
-    [ f <win> ] keep
+    [ dup handle>> hWnd>> register-window ]
-    [ swap hWnd>> register-window ] 2keep
+    [ handle>> hWnd>> show-window ] tri ;
-    dupd (>>handle)
-    hWnd>> show-window ;
 
 M: win-base select-gl-context ( handle -- )
     [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
@@ -504,15 +647,15 @@ M: win-base select-gl-context ( handle -- )
 M: win-base flush-gl-context ( handle -- )
     hDC>> SwapBuffers win32-error=0/f ;
 
-: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
+: setup-offscreen-gl ( world -- )
-    make-offscreen-dc-and-bitmap [
+    dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap
-        [ dup offscreen-pfd-dwFlags setup-pixel-format ]
+    [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [
-        [ get-rc ] bi
+        swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi
-    ] 2dip ;
+    ] with-world-pixel-format ;
 
 M: windows-ui-backend (open-offscreen-buffer) ( world -- )
-    dup dim>> setup-offscreen-gl <win-offscreen>
+    win-offscreen new >>handle
-    >>handle drop ;
+    setup-offscreen-gl ;
 
 M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
     [ hDC>> DeleteDC drop ]

basis/ui/backend/x11/x11.factor

@@ -7,7 +7,8 @@ namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
 x11.glx x11.clipboard x11.constants x11.windows x11.io
 io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
 command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii ;
+math.rectangles environment ascii literals
+ui.pixel-formats ui.pixel-formats.private ;
 IN: ui.backend.x11
 
 SINGLETON: x11-ui-backend
@@ -29,6 +30,40 @@ M: world configure-event
     ! In case dimensions didn't change
     relayout-1 ;
 
+PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
+    { double-buffered { $ GLX_DOUBLEBUFFER } }
+    { stereo { $ GLX_STEREO } }
+    { color-bits { $ GLX_BUFFER_SIZE } }
+    { red-bits { $ GLX_RED_SIZE } }
+    { green-bits { $ GLX_GREEN_SIZE } }
+    { blue-bits { $ GLX_BLUE_SIZE } }
+    { alpha-bits { $ GLX_ALPHA_SIZE } }
+    { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
+    { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
+    { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
+    { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
+    { depth-bits { $ GLX_DEPTH_SIZE } }
+    { stencil-bits { $ GLX_STENCIL_SIZE } }
+    { aux-buffers { $ GLX_AUX_BUFFERS } }
+    { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
+    { samples { $ GLX_SAMPLES } }
+}
+
+M: x11-ui-backend (make-pixel-format)
+    [ drop dpy get scr get ] dip
+    >glx-visual-int-array glXChooseVisual ;
+
+M: x11-ui-backend (free-pixel-format)
+    handle>> XFree ;
+
+M: x11-ui-backend (pixel-format-attribute)
+    [ dpy get ] 2dip
+    [ handle>> ] [ >glx-visual ] bi*
+    [ 2drop f ] [
+        first
+        0 <int> [ glXGetConfig drop ] keep *int
+    ] if-empty ;
+
 CONSTANT: modifiers
     {
         { S+ HEX: 1 }
@@ -187,7 +222,8 @@ M: world client-event
 
 : gadget-window ( world -- )
     dup
-    [ window-loc>> ] [ dim>> ] bi glx-window swap
+    [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
+    with-world-pixel-format swap
     dup "Factor" create-xic
     <x11-handle>
     [ window>> register-window ] [ >>handle drop ] 2bi ;
@@ -274,7 +310,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- )
     drop ;
 
 M: x11-ui-backend (open-offscreen-buffer) ( world -- )
-    dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+    dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
+    with-world-pixel-format
+    <x11-pixmap-handle> >>handle drop ;
 M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
     dpy get swap
     [ glx-pixmap>> glXDestroyGLXPixmap ]

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/glass/glass-tests.factor

@@ -1,10 +1,14 @@
 IN: ui.gadgets.glass.tests
 USING: tools.test ui.gadgets.glass ui.gadgets.worlds ui.gadgets
-math.rectangles namespaces accessors models sequences ;
+math.rectangles namespaces accessors models sequences arrays ;
 
-<gadget> "" f <model> <world>
+[ ] [
-{ 1000 1000 } >>dim
+    <world-attributes>
-"w" set
+    <gadget> 1array >>gadgets
+    <world>
+    { 1000 1000 } >>dim
+    "w" set
+] unit-test
 
 [ ] [ <gadget> "g" set ] unit-test
 

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

@@ -1,6 +1,6 @@
 USING: ui.gadgets ui.render ui.text ui.text.private
 ui.gestures ui.backend help.markup help.syntax
-models opengl strings ;
+models opengl sequences strings ;
 IN: ui.gadgets.worlds
 
 HELP: user-input
@@ -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-tests.factor

@@ -1,12 +1,12 @@
 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel accessors ;
+namespaces models kernel accessors arrays ;
 IN: ui.gadgets.worlds.tests
 
 ! Test focus behavior
 <gadget> "g1" set
 
 : <test-world> ( gadget -- world )
-    "Hi" f <world> ;
+    <world-attributes> "Hi" >>title swap 1array >>gadgets <world> ;
 
 [ ] [
     "g1" get <test-world> "w" set

basis/ui/gadgets/worlds/worlds.factor

@@ -4,15 +4,29 @@ 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.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 } ;
+
+: <world-attributes> ( -- world-attributes )
+    world-attributes new ; inline
 
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
 
@@ -45,18 +59,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 +96,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 +146,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
@@ -149,3 +190,14 @@ M: world handle-gesture ( gesture gadget -- ? )
 
 : close-global ( world global -- )
     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
+
+M: world world-pixel-format-attributes
+    pixel-format-attributes>> ;
+
+M: world check-world-pixel-format
+    2drop ;
+
+: 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

@@ -0,0 +1,198 @@
+USING: destructors help.markup help.syntax kernel math multiline sequences
+vocabs vocabs.parser words ;
+IN: ui.pixel-formats
+
+! break circular dependency
+<<
+    "ui.gadgets.worlds" create-vocab drop
+    "world" "ui.gadgets.worlds" create drop
+    "ui.gadgets.worlds" (use+)
+>>
+
+ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
+"The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:"
+{ $subsection double-buffered }
+{ $subsection stereo }
+{ $subsection offscreen }
+{ $subsection fullscreen }
+{ $subsection windowed }
+{ $subsection accelerated }
+{ $subsection software-rendered }
+{ $subsection backing-store }
+{ $subsection multisampled }
+{ $subsection supersampled }
+{ $subsection sample-alpha }
+{ $subsection color-float }
+"Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:"
+{ $subsection color-bits }
+{ $subsection red-bits }
+{ $subsection green-bits }
+{ $subsection blue-bits }
+{ $subsection alpha-bits }
+{ $subsection accum-bits }
+{ $subsection accum-red-bits }
+{ $subsection accum-green-bits }
+{ $subsection accum-blue-bits }
+{ $subsection accum-alpha-bits }
+{ $subsection depth-bits }
+{ $subsection stencil-bits }
+{ $subsection aux-buffers }
+{ $subsection sample-buffers }
+{ $subsection samples }
+{ $examples
+"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
+{ $code <"
+USING: kernel ui.worlds ui.pixel-formats ;
+IN: ui.pixel-formats.examples
+
+TUPLE: picky-depth-buffered-world < world ;
+
+M: picky-depth-buffered-world world-pixel-format-attributes
+    drop {
+        double-buffered
+        T{ color-bits { value 24 } }
+        T{ depth-bits { value 24 } }
+    } ;
+
+M: picky-depth-buffered-world check-world-pixel-format
+    nip
+    [ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ]
+    [ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
+    [ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
+    tri ;
+"> } }
+;
+
+HELP: double-buffered
+{ $class-description "Requests a double-buffered pixel format." } ;
+HELP: stereo
+{ $class-description "Requests a stereoscopic pixel format." } ;
+
+HELP: offscreen
+{ $class-description "Requests a pixel format suitable for offscreen rendering." } ;
+HELP: fullscreen
+{ $class-description "Requests a pixel format suitable for fullscreen rendering." }
+{ $notes "On some window systems this is not distinct from " { $link windowed } "." } ;
+HELP: windowed
+{ $class-description "Requests a pixel format suitable for rendering to a window." } ;
+
+{ offscreen fullscreen windowed } related-words
+
+HELP: accelerated
+{ $class-description "Requests a pixel format supported by GPU hardware acceleration." } ;
+HELP: software-rendered
+{ $class-description "Requests a pixel format only supported by the window system's default software renderer." } ;
+
+{ accelerated software-rendered } related-words
+
+HELP: backing-store
+{ $class-description "Used with " { $link double-buffered } " to request a double-buffered pixel format where the back buffer contents are preserved and copied to the front when buffers are swapped." } ;
+
+{ 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 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 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 color buffer is stored in floating-point format." } ;
+
+HELP: color-bits
+{ $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 a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
+HELP: green-bits
+{ $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 a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
+HELP: alpha-bits
+{ $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
+
+HELP: accum-bits
+{ $class-description "Requests a pixel format with an accumulation buffer of at least " { $snippet "value" } " bits per pixel." } ;
+HELP: accum-red-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " red bits per pixel." } ;
+HELP: accum-green-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " green bits per pixel." } ;
+HELP: accum-blue-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
+HELP: accum-alpha-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
+
+{ accum-bits accum-red-bits accum-green-bits accum-blue-bits accum-alpha-bits } related-words
+
+HELP: depth-bits
+{ $class-description "Requests a pixel format with a depth buffer of at least " { $snippet "value" } " bits per pixel." } ;
+
+HELP: stencil-bits
+{ $class-description "Requests a pixel format with a stencil buffer of at least " { $snippet "value" } " bits per pixel." } ;
+
+HELP: aux-buffers
+{ $class-description "Requests a pixel format with at least " { $snippet "value" } " auxiliary buffers." } ;
+
+HELP: sample-buffers
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request a pixel format with at least " { $snippet "value" } " sampling buffers." } ;
+
+HELP: samples
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request at least " { $snippet "value" } " samples per pixel." } ;
+
+{ multisampled supersampled sample-alpha sample-buffers samples } related-words
+
+HELP: world-pixel-format-attributes
+{ $values { "world" world } { "attributes" sequence } }
+{ $description "Returns the set of " { $link "ui.pixel-formats-attributes" } " that " { $snippet "world" } " requests when grafted. This generic can be overridden by subclasses of " { $snippet "world" } "." }
+{ $notes "The pixel format provided by the window system will not necessarily exactly match the requested attributes. To verify required pixel format attributes, override " { $link check-world-pixel-format } "." } ;
+
+HELP: check-world-pixel-format
+{ $values { "world" world } { "pixel-format" pixel-format } }
+{ $description "Verifies that " { $snippet "pixel-format" } " fulfills the requirements of " { $snippet "world" } ". The default method does nothing. Subclasses can override this generic to perform their own checks on the pixel format." } ;
+
+HELP: pixel-format
+{ $class-description "The type of pixel format objects. The tuple slot contents should be considered opaque by user code. To check the value of a pixel format's attributes, use the " { $link pixel-format-attribute } " word. Pixel format objects must be freed using the " { $link dispose } " word when they are no longer needed." } ;
+
+HELP: <pixel-format>
+{ $values { "world" world } { "attributes" sequence } { "pixel-format" pixel-format } }
+{ $description "Requests a pixel format suitable for " { $snippet "world" } " with a set of " { $link "ui.pixel-formats-attributes" } ". If no pixel format can be found that satisfies the given attributes, an " { $link invalid-pixel-format-attributes } " error is thrown. Pixel format attributes not supported by the window system are ignored. The returned " { $snippet "pixel-format" } " must be released using the " { $link dispose } " word when it is no longer needed." }
+{ $notes "Pixel formats don't normally need to be directly allocated by user code. If you need to control the pixel format requested by a window, subclass " { $snippet "world" } " and override the " { $link world-pixel-format-attributes } " and " { $link check-world-pixel-format } " words."
+$nl
+"The returned pixel format does not necessarily exactly match the requested attributes; the window system will try to find the format that best matches the given attributes. Use " { $link pixel-format-attribute } " to check the actual values of the attributes on the returned pixel format." }
+;
+
+HELP: pixel-format-attribute
+{ $values { "pixel-format" pixel-format } { "attribute-name" "one of the " { $link "ui.pixel-formats-attributes" } } { "value" object } }
+{ $description "Returns the value of the requested " { $snippet "attribute-name" } " in " { $snippet "pixel-format" } ". If " { "attribute-name" } " is unsupported by the window system, " { $link f } " is returned." } ;
+
+HELP: invalid-pixel-format-attributes
+{ $values { "world" world } { "attributes" sequence } }
+{ $class-description "Thrown by " { $link <pixel-format> } " when the window system is unable to find a pixel format for " { $snippet "world" } " that satisfies the requested " { $snippet "attributes" } "." } ;
+
+{ world-pixel-format-attributes check-world-pixel-format pixel-format <pixel-format> pixel-format-attribute }
+related-words
+
+ARTICLE: "ui.pixel-formats" "Pixel formats"
+"The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:"
+{ $subsection "ui.pixel-formats-attributes" }
+
+"Pixel formats can be requested using these attributes:"
+{ $subsection pixel-format }
+{ $subsection <pixel-format> }
+{ $subsection pixel-format-attribute }
+
+"If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:"
+{ $subsection invalid-pixel-format-attributes }
+
+"Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:"
+{ $subsection world-pixel-format-attributes }
+{ $subsection check-world-pixel-format }
+;
+
+ABOUT: "ui.pixel-formats"

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

@@ -0,0 +1,94 @@
+USING: accessors assocs classes destructors functors kernel
+lexer math parser sequences specialized-arrays.int ui.backend
+words.symbol ;
+IN: ui.pixel-formats
+
+SYMBOLS:
+    double-buffered
+    stereo
+    offscreen
+    fullscreen
+    windowed
+    accelerated
+    software-rendered
+    backing-store
+    multisampled
+    supersampled 
+    sample-alpha
+    color-float ;
+
+TUPLE: pixel-format-attribute { value integer } ;
+
+TUPLE: color-bits < pixel-format-attribute ;
+TUPLE: red-bits < pixel-format-attribute ;
+TUPLE: green-bits < pixel-format-attribute ;
+TUPLE: blue-bits < pixel-format-attribute ;
+TUPLE: alpha-bits < pixel-format-attribute ;
+
+TUPLE: accum-bits < pixel-format-attribute ;
+TUPLE: accum-red-bits < pixel-format-attribute ;
+TUPLE: accum-green-bits < pixel-format-attribute ;
+TUPLE: accum-blue-bits < pixel-format-attribute ;
+TUPLE: accum-alpha-bits < pixel-format-attribute ;
+
+TUPLE: depth-bits < pixel-format-attribute ;
+
+TUPLE: stencil-bits < pixel-format-attribute ;
+
+TUPLE: aux-buffers < pixel-format-attribute ;
+
+TUPLE: sample-buffers < pixel-format-attribute ;
+TUPLE: samples < pixel-format-attribute ;
+
+HOOK: (make-pixel-format) ui-backend ( world attributes -- pixel-format-handle )
+HOOK: (free-pixel-format) ui-backend ( pixel-format -- )
+HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value )
+
+ERROR: invalid-pixel-format-attributes world attributes ;
+
+TUPLE: pixel-format world handle ;
+
+: <pixel-format> ( world attributes -- pixel-format )
+    2dup (make-pixel-format)
+    [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ;
+
+M: pixel-format dispose
+    [ (free-pixel-format) ] [ f >>handle drop ] bi ;
+
+: pixel-format-attribute ( pixel-format attribute-name -- value )
+    (pixel-format-attribute) ;
+
+<PRIVATE
+
+FUNCTOR: define-pixel-format-attribute-table ( NAME PERM TABLE -- )
+
+>PFA              DEFINES >${NAME}
+>PFA-int-array    DEFINES >${NAME}-int-array
+
+WHERE
+
+GENERIC: >PFA ( attribute -- pfas )
+
+M: object >PFA
+    drop { } ;
+M: symbol >PFA
+    TABLE at [ { } ] unless* ;
+M: pixel-format-attribute >PFA
+    dup class TABLE at
+    [ swap value>> suffix ]
+    [ drop { } ] if* ;
+
+: >PFA-int-array ( attribute -- int-array )
+    [ >PFA ] map concat PERM prepend 0 suffix >int-array ;
+
+;FUNCTOR
+
+SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE:
+    scan scan-object scan-object define-pixel-format-attribute-table ;
+
+PRIVATE>
+
+GENERIC: world-pixel-format-attributes ( world -- attributes )
+
+GENERIC# check-world-pixel-format 1 ( world pixel-format -- )
+

basis/ui/pixel-formats/summary.txt

@@ -0,0 +1 @@
+Cross-platform OpenGL context pixel format specifiers

basis/ui/text/text.factor

@@ -75,10 +75,8 @@ M: array draw-text
 
 USING: vocabs.loader namespaces system combinators ;
 
-"ui-backend" get [
+{
-    {
+    { [ os macosx? ] [ "core-text" ] }
-        { [ os macosx? ] [ "core-text" ] }
+    { [ os windows? ] [ "uniscribe" ] }
-        { [ os windows? ] [ "uniscribe" ] }
+    { [ os unix? ] [ "pango" ] }
-        { [ os unix? ] [ "pango" ] }
+} cond "ui.text." prepend require
-    } cond
-] unless* "ui.text." prepend require

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-tests.factor

@@ -0,0 +1,9 @@
+IN: vocabs.files.tests
+USING: tools.test vocabs.files vocabs arrays grouping ;
+
+[ t ] [
+    "kernel" vocab-files
+    "kernel" vocab vocab-files
+    "kernel" <vocab-link> vocab-files
+    3array all-equal?
+] unit-test

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 } { "vocabs" "a sequence of vocabularies" } }
+{ $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." } ;