Imported https://downloads.factorcode.org/releases/0.95/factor-src-0.95.zip

Factor.app/Contents/Info.plist

@@ -34,7 +34,7 @@
 	<key>CFBundleVersion</key>
 	<string>0.94</string>
 	<key>NSHumanReadableCopyright</key>
-	<string>Copyright © 2003-2010 Factor developers</string>
+	<string>Copyright © 2003-2011 Factor developers</string>
 	<key>NSServices</key>
 	<array>
 		<dict>

GNUmakefile

@@ -1,14 +1,14 @@
 ifdef CONFIG
 	CC = gcc
 	CPP = g++
-	AR = ar
-	LD = ld
 
 	VERSION = 0.94
 
 	BUNDLE = Factor.app
 	LIBPATH = -L/usr/X11R6/lib
 
+	include $(CONFIG)
+
 	CFLAGS = -Wall $(SITE_CFLAGS)
 
 	ifdef DEBUG
@@ -17,8 +17,6 @@ ifdef CONFIG
 		CFLAGS += -O3
 	endif
 
-	include $(CONFIG)
-
 	ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
 	EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
 	CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
@@ -58,9 +56,10 @@ ifdef CONFIG
 		vm/object_start_map.o \
 		vm/objects.o \
 		vm/primitives.o \
-		vm/profiler.o \
 		vm/quotations.o \
 		vm/run.o \
+		vm/safepoints.o \
+		vm/sampling_profiler.o \
 		vm/strings.o \
 		vm/to_tenured_collector.o \
 		vm/tuples.o \
@@ -68,6 +67,75 @@ ifdef CONFIG
 		vm/vm.o \
 		vm/words.o
 
+	MASTER_HEADERS = $(PLAF_MASTER_HEADERS) \
+		vm/assert.hpp \
+		vm/layouts.hpp \
+		vm/platform.hpp \
+		vm/primitives.hpp \
+		vm/segments.hpp \
+		vm/gc_info.hpp \
+		vm/contexts.hpp \
+		vm/run.hpp \
+		vm/objects.hpp \
+		vm/sampling_profiler.hpp \
+		vm/errors.hpp \
+		vm/bignumint.hpp \
+		vm/bignum.hpp \
+		vm/booleans.hpp \
+		vm/instruction_operands.hpp \
+		vm/code_blocks.hpp \
+		vm/bump_allocator.hpp \
+		vm/bitwise_hacks.hpp \
+		vm/mark_bits.hpp \
+		vm/free_list.hpp \
+		vm/fixup.hpp \
+		vm/tuples.hpp \
+		vm/free_list_allocator.hpp \
+		vm/write_barrier.hpp \
+		vm/object_start_map.hpp \
+		vm/nursery_space.hpp \
+		vm/aging_space.hpp \
+		vm/tenured_space.hpp \
+		vm/data_heap.hpp \
+		vm/code_heap.hpp \
+		vm/gc.hpp \
+		vm/debug.hpp \
+		vm/strings.hpp \
+		vm/words.hpp \
+		vm/float_bits.hpp \
+		vm/io.hpp \
+		vm/image.hpp \
+		vm/alien.hpp \
+		vm/callbacks.hpp \
+		vm/dispatch.hpp \
+		vm/entry_points.hpp \
+		vm/safepoints.hpp \
+		vm/vm.hpp \
+		vm/allot.hpp \
+		vm/tagged.hpp \
+		vm/data_roots.hpp \
+		vm/code_roots.hpp \
+		vm/generic_arrays.hpp \
+		vm/callstack.hpp \
+		vm/slot_visitor.hpp \
+		vm/collector.hpp \
+		vm/copying_collector.hpp \
+		vm/nursery_collector.hpp \
+		vm/aging_collector.hpp \
+		vm/to_tenured_collector.hpp \
+		vm/code_block_visitor.hpp \
+		vm/compaction.hpp \
+		vm/full_collector.hpp \
+		vm/arrays.hpp \
+		vm/math.hpp \
+		vm/byte_arrays.hpp \
+		vm/jit.hpp \
+		vm/quotations.hpp \
+		vm/inline_cache.hpp \
+		vm/mvm.hpp \
+		vm/factor.hpp \
+		vm/utilities.hpp
+
 	EXE_OBJS = $(PLAF_EXE_OBJS)
 
 	FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
@@ -81,24 +149,16 @@ default:
 help:
 	@echo "Run '$(MAKE)' with one of the following parameters:"
 	@echo ""
-	@echo "freebsd-x86-32"
-	@echo "freebsd-x86-64"
 	@echo "linux-x86-32"
 	@echo "linux-x86-64"
-	@echo "linux-ppc"
+	@echo "linux-ppc-32"
+	@echo "linux-ppc-64"
 	@echo "linux-arm"
-	@echo "openbsd-x86-32"
-	@echo "openbsd-x86-64"
-	@echo "netbsd-x86-32"
-	@echo "netbsd-x86-64"
 	@echo "macosx-x86-32"
 	@echo "macosx-x86-64"
-	@echo "macosx-ppc"
+	@echo "macosx-x86-fat"
-	@echo "solaris-x86-32"
+	@echo "windows-x86-32"
-	@echo "solaris-x86-64"
+	@echo "windows-x86-64"
-	@echo "wince-arm"
-	@echo "winnt-x86-32"
-	@echo "winnt-x86-64"
 	@echo ""
 	@echo "Additional modifiers:"
 	@echo ""
@@ -109,61 +169,37 @@ help:
 
 ALL = factor factor-ffi-test factor-lib
 
-openbsd-x86-32:
-	$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.32
-
-openbsd-x86-64:
-	$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.64
-
-freebsd-x86-32:
-	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
-
-freebsd-x86-64:
-	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
-
-netbsd-x86-32:
-	$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.32
-
-netbsd-x86-64:
-	$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.64
-
-macosx-ppc:
-	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.ppc
-
 macosx-x86-32:
 	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
 
 macosx-x86-64:
 	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
 
+macosx-x86-fat:
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.fat
+
 linux-x86-32:
 	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
 
 linux-x86-64:
 	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
 
-linux-ppc:
+linux-ppc-32:
-	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.32
+
+linux-ppc-64:
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.64
 
 linux-arm:
 	$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
 
-solaris-x86-32:
+windows-x86-32:
-	$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.32
+	$(MAKE) factor-console CONFIG=vm/Config.windows.x86.32
 
-solaris-x86-64:
+windows-x86-64:
-	$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.64
-
+	$(MAKE) factor-console CONFIG=vm/Config.windows.x86.64
-winnt-x86-32:
-	$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32
-	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
-
-winnt-x86-64:
-	$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
-	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
-
-wince-arm:
-	$(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
 
 ifdef CONFIG
 
@@ -179,12 +215,12 @@ $(ENGINE): $(DLL_OBJS)
 factor-lib: $(ENGINE)
 
 factor: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \
-		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
+		$(CFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS)
 
 factor-console: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \
-		$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
+		$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(LIBS) $(EXE_OBJS)
 
 factor-ffi-test: $(FFI_TEST_LIBRARY)
 
@@ -197,13 +233,16 @@ vm/resources.o:
 vm/ffi_test.o: vm/ffi_test.c
 	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
 
-.cpp.o:
+vm/master.hpp.gch: vm/master.hpp $(MASTER_HEADERS)
+	$(TOOLCHAIN_PREFIX)$(CPP) -c -x c++-header $(CFLAGS) -o $@ $<
+
+%.o: %.cpp vm/master.hpp.gch
 	$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
 
-.S.o:
+%.o: %.S
-	$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
+	$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
 
-.mm.o:
+%.o: %.mm vm/master.hpp.gch
 	$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
 
 .SUFFIXES: .mm
@@ -211,6 +250,7 @@ vm/ffi_test.o: vm/ffi_test.c
 endif
 
 clean:
+	rm -f vm/*.gch
 	rm -f vm/*.o
 	rm -f factor.dll
 	rm -f factor.lib

Nmakefile

@@ -14,18 +14,17 @@ CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
 
 !IF "$(PLATFORM)" == "x86-32"
 LINK_FLAGS = $(LINK_FLAGS) /safeseh
-PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
+PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
 !ELSEIF "$(PLATFORM)" == "x86-64"
-PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
+PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
 !ENDIF
 
 ML_FLAGS = /nologo /safeseh
 
-EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
+EXE_OBJS = vm\main-windows.obj vm\factor.res
 
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm\os-windows.obj \
-	vm\os-windows-nt.obj \
 	vm\aging_collector.obj \
 	vm\alien.obj \
 	vm\arrays.obj \
@@ -56,14 +55,15 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm\jit.obj \
 	vm\math.obj \
 	vm\mvm.obj \
-	vm\mvm-windows-nt.obj \
+	vm\mvm-windows.obj \
 	vm\nursery_collector.obj \
 	vm\object_start_map.obj \
 	vm\objects.obj \
 	vm\primitives.obj \
-	vm\profiler.obj \
 	vm\quotations.obj \
 	vm\run.obj \
+	vm\safepoints.obj \
+	vm\sampling_profiler.obj \
 	vm\strings.obj \
 	vm\to_tenured_collector.obj \
 	vm\tuples.obj \

README.md

@@ -0,0 +1,127 @@
+# Factor
+
+The Factor programming language combines [powerful language
+features](http://concatenative.org/wiki/view/Factor/Features/The%20language)
+with a [full-featured
+library](http://docs.factorcode.org/content/article-vocab-index.html). The
+implementation is [fully
+compiled](http://concatenative.org/wiki/view/Factor/Optimizing%20compiler)
+for performance, while still supporting [interactive
+development](http://concatenative.org/wiki/view/Factor/Interactive%20development).
+Factor applications are portable between all common platforms.  Factor can
+[deploy stand-alone
+applications](http://concatenative.org/wiki/view/Factor/Deployment) on all
+platforms.  Full source code for the Factor project is available under a BSD
+license.
+
+## Getting Started
+
+### Building Factor from source
+
+If you have a build environment set up, then you can build Factor from git.
+These scripts will attempt to compile the Factor binary and bootstrap from
+a boot image stored on factorcode.org.
+
+To check out Factor:
+
+* `git clone git://factorcode.org/git/factor.git`
+* `cd factor`
+
+To build the latest complete Factor system from git:
+
+* Windows: `build-support\factor.cmd`
+* Unix: `./build-support/factor.sh update`
+
+Now you should have a complete Factor system ready to run.
+
+More information on [building factor](http://concatenative.org/wiki/view/Factor/Building%20Factor)
+and [system requirements](http://concatenative.org/wiki/view/Factor/Requirements).
+
+### To run a Factor binary:
+
+You can download a Factor binary from the grid on [http://factorcode.org](http://factorcode.org).
+The nightly builds are usually a better experience than the point releases.
+
+* Windows: Double-click `factor.exe`, or run `.\factor.com` in a command prompt
+* Mac OS X: Double-click `Factor.app` or run `open Factor.app` in a Terminal
+* Unix: Run `./factor` in a shell
+
+### Learning Factor
+
+A tutorial is available that can be accessed from the Factor environment:
+
+```factor
+"first-program" help
+```
+
+Some other simple things you can try in the listener:
+
+```factor
+"Hello, world" print
+
+{ 4 8 15 16 23 42 } [ 2 * ] map .
+
+1000 [1,b] sum .
+
+4 iota  [
+    "Happy Birthday " write
+    2 = "dear NAME" "to You" ? print
+] each
+```
+
+For more tips, see [Learning Factor](http://concatenative.org/wiki/view/Factor/Learning).
+
+## Documentation
+
+The Factor environment includes extensive reference documentation and a
+short "cookbook" to help you get started. The best way to read the
+documentation is in the UI; press F1 in the UI listener to open the help
+browser tool. You can also [browse the documentation
+online](http://docs.factorcode.org).
+
+## Command Line Usage
+
+Factor supports a number of command line switches:
+
+```
+Usage: factor [Factor arguments] [script] [script arguments]
+
+Common arguments:
+    -help            print this message and exit
+    -i=<image>       load Factor image file <image> (default factor.image)
+    -run=<vocab>     run the MAIN: entry point of <vocab>
+        -run=listener    run terminal listener
+        -run=ui.tools    run Factor development UI
+    -e=<code>        evaluate <code>
+    -no-user-init    suppress loading of .factor-rc
+
+Enter
+    "command-line" help
+from within Factor for more information.
+```
+
+You can also write scripts that can be run from the terminal, by putting
+``#!/path/to/factor`` at the top of your scripts and making them executable.
+
+## Source Organization
+
+The Factor source tree is organized as follows:
+
+* `build-support/` - scripts used for compiling Factor (not present in binary packages)
+* `vm/` - Factor VM source code (not present in binary packages)
+* `core/` - Factor core library
+* `basis/` - Factor basis library, compiler, tools
+* `extra/` - more libraries and applications
+* `misc/` - editor modes, icons, etc
+* `unmaintained/` - unmaintained contributions, please help!
+
+## Community
+
+Factor developers meet in the `#concatenative` channel on
+[irc.freenode.net](http://freenode.net). Drop by if you want to discuss
+anything related to Factor or language design in general.
+
+* [Factor homepage](http://factorcode.org)
+* [Concatenative languages wiki](http://concatenative.org)
+
+Have fun!

basis/alien/arrays/arrays.factor

@@ -7,7 +7,7 @@ IN: alien.arrays
 
 INSTANCE: array value-type
 
-M: array c-type ;
+M: array lookup-c-type ;
 
 M: array c-type-class drop object ;
 
@@ -27,7 +27,7 @@ M: array base-type drop void* base-type ;
 PREDICATE: string-type < pair
     first2 [ c-string = ] [ word? ] bi* and ;
 
-M: string-type c-type ;
+M: string-type lookup-c-type ;
 
 M: string-type c-type-class drop object ;
 

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

@@ -1,6 +1,6 @@
-USING: alien alien.complex help.syntax help.markup libc kernel.private
+USING: alien help.syntax help.markup libc kernel.private
-byte-arrays strings hashtables alien.syntax alien.strings sequences
+byte-arrays strings hashtables alien.syntax alien.strings
-io.encodings.string debugger destructors vocabs.loader
+sequences io.encodings.string debugger destructors vocabs.loader
 classes.struct math kernel ;
 QUALIFIED: math
 QUALIFIED: sequences
@@ -21,9 +21,9 @@ HELP: <c-type>
 HELP: no-c-type
 { $values { "name" c-type-name } }
 { $description "Throws a " { $link no-c-type } " error." }
-{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
+{ $error-description "Thrown by " { $link c-type } " if a given word is not a C type." } ;
 
-HELP: c-type
+HELP: lookup-c-type
 { $values { "name" c-type-name } { "c-type" c-type } }
 { $description "Looks up a C type by name." }
 { $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
@@ -38,16 +38,6 @@ HELP: set-alien-value
 { $description "Stores a value at a byte offset from a base C pointer." }
 { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
 
-HELP: define-deref
-{ $values { "c-type" "a C type" } }
-{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
-{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
-
-HELP: define-out
-{ $values { "c-type" "a C type" } }
-{ $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." } ;
-
 HELP: char
 { $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
 HELP: uchar
@@ -86,17 +76,13 @@ HELP: float
 { $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
 HELP: double
 { $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ;
-HELP: complex-float
-{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
-HELP: complex-double
-{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
 
 HELP: pointer:
 { $syntax "pointer: c-type" }
 { $description "Constructs a " { $link pointer } " C type." } ;
 
 HELP: pointer
-{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to." { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs."
+{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to. Both " { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs."
 $nl
 "Pointer output values are represented in Factor as " { $link alien } "s. If the pointed-to type is a struct, the alien will automatically be wrapped in a struct object if it is not null."
 $nl
@@ -118,43 +104,6 @@ $nl
 "If this condition is not satisfied, " { $link "malloc" } " must be used instead."
 { $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
 
-ARTICLE: "c-out-params" "Output parameters in C"
-"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
-$nl
-"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
-{ $subsections
-    <char>
-    <uchar>
-    <short>
-    <ushort>
-    <int>
-    <uint>
-    <long>
-    <ulong>
-    <longlong>
-    <ulonglong>
-    <float>
-    <double>
-    <void*>
-}
-"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
-{ $subsections
-    *char
-    *uchar
-    *short
-    *ushort
-    *int
-    *uint
-    *long
-    *ulong
-    *longlong
-    *ulonglong
-    *float
-    *double
-    *void*
-}
-"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
-
 ARTICLE: "c-types.primitives" "Primitive C types"
 "The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
 { $table
@@ -172,11 +121,8 @@ ARTICLE: "c-types.primitives" "Primitive C types"
     { { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
     { { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
 }
-"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
+"C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary."
-{ $table
+$nl
-    { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
-    { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } }
-}
 "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
 
 ARTICLE: "c-types.pointers" "Pointer and array types"
@@ -226,6 +172,8 @@ $nl
     POSTPONE: CALLBACK:
     POSTPONE: TYPEDEF:
 }
+"Getting the c-type of a class:"
+{ $subsections lookup-c-type }
 { $heading "Related articles" }
 { $subsections
     "c-types.primitives"

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

@@ -2,34 +2,31 @@ USING: alien alien.syntax alien.c-types alien.parser
 eval kernel tools.test sequences system libc alien.strings
 io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
 accessors compiler.units ;
+FROM: alien.c-types => short ;
 IN: alien.c-types.tests
 
 CONSTANT: xyz 123
 
 [ 492 ] [ { int xyz } heap-size ] unit-test
 
-[ -1 ] [ -1 <char> *char ] unit-test
-[ -1 ] [ -1 <short> *short ] unit-test
-[ -1 ] [ -1 <int> *int ] unit-test
-
 UNION-STRUCT: foo
     { a int }
     { b int } ;
 
-[ t ] [ pointer: void c-type void* c-type = ] unit-test
+[ t ] [ pointer: void lookup-c-type void* lookup-c-type = ] unit-test
-[ t ] [ pointer: int  c-type void* c-type = ] unit-test
+[ t ] [ pointer: int  lookup-c-type void* lookup-c-type = ] unit-test
-[ t ] [ pointer: int* c-type void* c-type = ] unit-test
+[ t ] [ pointer: int* lookup-c-type void* lookup-c-type = ] unit-test
-[ f ] [ pointer: foo  c-type void* c-type = ] unit-test
+[ f ] [ pointer: foo  lookup-c-type void* lookup-c-type = ] unit-test
-[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
+[ t ] [ pointer: foo* lookup-c-type void* lookup-c-type = ] unit-test
 
-[ t ] [ c-string c-type c-string c-type = ] unit-test
+[ t ] [ c-string lookup-c-type c-string lookup-c-type = ] unit-test
 
 [ t ] [ foo heap-size int heap-size = ] unit-test
 
 TYPEDEF: int MyInt
 
-[ t ] [ int   c-type          MyInt c-type = ] unit-test
+[ t ] [ int   lookup-c-type          MyInt lookup-c-type = ] unit-test
-[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
+[ t ] [ void* lookup-c-type pointer: MyInt lookup-c-type = ] unit-test
 
 [ 32 ] [ { int 8 } heap-size ] unit-test
 
@@ -37,28 +34,20 @@ TYPEDEF: int MyInt
 
 TYPEDEF: char MyChar
 
-[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
+[ t ] [ pointer: void lookup-c-type pointer: MyChar lookup-c-type = ] unit-test
 
 TYPEDEF: { c-string ascii } MyFunkyString
 
-[ { c-string ascii } ] [ MyFunkyString c-type ] unit-test
+[ { c-string ascii } ] [ MyFunkyString lookup-c-type ] unit-test
 
 TYPEDEF: c-string MyString
 
-[ t ] [ c-string c-type MyString          c-type = ] unit-test
+[ t ] [ c-string lookup-c-type MyString          lookup-c-type = ] unit-test
-[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
+[ t ] [ void* lookup-c-type pointer: MyString lookup-c-type = ] unit-test
 
 TYPEDEF: int* MyIntArray
 
-[ t ] [ void* c-type MyIntArray c-type = ] unit-test
+[ t ] [ void* lookup-c-type MyIntArray lookup-c-type = ] unit-test
-
-[
-    0 B{ 1 2 3 4 } <displaced-alien> <void*>
-] must-fail
-
-os windows? cpu x86.64? and [
-    [ -2147467259 ] [ 2147500037 <long> *long ] unit-test
-] when
 
 [ 0 ] [ -10 uchar c-type-clamp ] unit-test
 [ 12 ] [ 12 uchar c-type-clamp ] unit-test
@@ -68,8 +57,8 @@ os windows? cpu x86.64? and [
 
 C-TYPE: opaque
 
-[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
+[ t ] [ void* lookup-c-type pointer: opaque lookup-c-type = ] unit-test
-[ opaque c-type ] [ no-c-type? ] must-fail-with
+[ opaque lookup-c-type ] [ no-c-type? ] must-fail-with
 
 [ """
     USING: alien.syntax ;
@@ -81,8 +70,8 @@ C-TYPE: forward
 STRUCT: backward { x forward* } ;
 STRUCT: forward { x backward* } ;
 
-[ t ] [ forward c-type struct-c-type? ] unit-test
+[ t ] [ forward lookup-c-type struct-c-type? ] unit-test
-[ t ] [ backward c-type struct-c-type? ] unit-test
+[ t ] [ backward lookup-c-type struct-c-type? ] unit-test
 
 DEFER: struct-redefined
 

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

@@ -1,12 +1,9 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs delegate kernel kernel.private math
+USING: accessors alien alien.accessors arrays byte-arrays
-math.order math.parser namespaces make parser sequences strings
+classes combinators compiler.units cpu.architecture delegate
-words splitting cpu.architecture alien alien.accessors
+fry kernel layouts locals macros math math.order quotations
-alien.strings quotations layouts system compiler.units io
+sequences system words words.symbol summary ;
-io.files io.encodings.binary io.streams.memory accessors
-combinators effects continuations fry classes vocabs
-vocabs.loader words.symbol macros ;
 QUALIFIED: math
 IN: alien.c-types
 
@@ -21,9 +18,6 @@ SYMBOLS:
 
 SINGLETON: void
 
-DEFER: <int>
-DEFER: *char
-
 TUPLE: abstract-c-type
 { class class initial: object }
 { boxed-class class initial: object }
@@ -43,13 +37,15 @@ unboxer
 : <c-type> ( -- c-type )
     \ c-type new ; inline
 
-ERROR: no-c-type name ;
+ERROR: no-c-type word ;
+
+M: no-c-type summary drop "Not a C type" ;
 
 ! C type protocol
-GENERIC: c-type ( name -- c-type ) foldable
+GENERIC: lookup-c-type ( name -- c-type ) foldable
 
 PREDICATE: c-type-word < word
-    "c-type" word-prop ;
+    "c-type" word-prop >boolean ;
 
 TUPLE: pointer { to initial: void read-only } ;
 C: <pointer> pointer
@@ -59,12 +55,13 @@ UNION: c-type-name
 
 : resolve-typedef ( name -- c-type )
     dup void? [ no-c-type ] when
-    dup c-type-name? [ c-type ] when ;
+    dup c-type-name? [ lookup-c-type ] when ;
 
-M: word c-type
+M: word lookup-c-type
     dup "c-type" word-prop resolve-typedef
     [ ] [ no-c-type ] ?if ;
 
+
 GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
@@ -107,12 +104,10 @@ M: abstract-c-type c-type-align-first align-first>> ;
 
 GENERIC: base-type ( c-type -- c-type )
 
-M: c-type-name base-type c-type ;
+M: c-type-name base-type lookup-c-type ;
 
 M: c-type base-type ;
 
-: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-
 GENERIC: heap-size ( name -- size )
 
 M: abstract-c-type heap-size size>> ;
@@ -154,7 +149,7 @@ PROTOCOL: c-type-protocol
     heap-size ;
 
 CONSULT: c-type-protocol c-type-name
-    c-type ;
+    lookup-c-type ;
 
 PREDICATE: typedef-word < c-type-word
     "c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
@@ -170,20 +165,7 @@ TUPLE: long-long-type < c-type ;
 : <long-long-type> ( -- c-type )
     long-long-type new ;
 
-: define-deref ( c-type -- )
+: if-void ( ..a c-type true: ( ..a -- ..b ) false: ( ..a c-type -- ..b ) -- ..b )
-    [ name>> CHAR: * prefix "alien.c-types" create ]
-    [ '[ 0 _ alien-value ] ]
-    bi (( c-ptr -- value )) define-inline ;
-
-: define-out ( c-type -- )
-    [ name>> "alien.c-types" constructor-word ]
-    [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
-    (( value -- c-ptr )) define-inline ;
-
-: define-primitive-type ( c-type name -- )
-    [ typedef ] [ define-deref ] [ define-out ] tri ;
-
-: if-void ( c-type true false -- )
     pick void? [ drop nip call ] [ nip call ] if ; inline
 
 SYMBOLS:
@@ -210,7 +192,6 @@ CONSTANT: primitive-types
 
 : 8-byte-alignment ( c-type -- c-type )
     {
-        { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
         { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
         [ 8 >>align 8 >>align-first ]
     } cond ;
@@ -231,8 +212,8 @@ CONSTANT: primitive-types
 
 PRIVATE>
 
-M: pointer c-type
+M: pointer lookup-c-type
-    [ \ void* c-type ] dip
+    [ \ void* lookup-c-type ] dip
     to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
 
 [
@@ -247,7 +228,7 @@ M: pointer c-type
         [ >c-ptr ] >>unboxer-quot
         "allot_alien" >>boxer
         "alien_offset" >>unboxer
-    \ void* define-primitive-type
+    \ void* typedef
 
     <c-type>
         fixnum >>class
@@ -260,7 +241,7 @@ M: pointer c-type
         "from_signed_2" >>boxer
         "to_signed_2" >>unboxer
         [ >fixnum ] >>unboxer-quot
-    \ short define-primitive-type
+    \ short typedef
 
     <c-type>
         fixnum >>class
@@ -273,7 +254,7 @@ M: pointer c-type
         "from_unsigned_2" >>boxer
         "to_unsigned_2" >>unboxer
         [ >fixnum ] >>unboxer-quot
-    \ ushort define-primitive-type
+    \ ushort typedef
 
     <c-type>
         fixnum >>class
@@ -286,7 +267,7 @@ M: pointer c-type
         "from_signed_1" >>boxer
         "to_signed_1" >>unboxer
         [ >fixnum ] >>unboxer-quot
-    \ char define-primitive-type
+    \ char typedef
 
     <c-type>
         fixnum >>class
@@ -299,7 +280,7 @@ M: pointer c-type
         "from_unsigned_1" >>boxer
         "to_unsigned_1" >>unboxer
         [ >fixnum ] >>unboxer-quot
-    \ uchar define-primitive-type
+    \ uchar typedef
 
     <c-type>
         math:float >>class
@@ -313,7 +294,7 @@ M: pointer c-type
         "to_float" >>unboxer
         float-rep >>rep
         [ >float ] >>unboxer-quot
-    \ float define-primitive-type
+    \ float typedef
 
     <c-type>
         math:float >>class
@@ -326,7 +307,7 @@ M: pointer c-type
         "to_double" >>unboxer
         double-rep >>rep
         [ >float ] >>unboxer-quot
-    \ double define-primitive-type
+    \ double typedef
 
     cell 8 = [
         <c-type>
@@ -340,7 +321,7 @@ M: pointer c-type
             "from_signed_4" >>boxer
             "to_signed_4" >>unboxer
             [ >fixnum ] >>unboxer-quot
-        \ int define-primitive-type
+        \ int typedef
     
         <c-type>
             fixnum >>class
@@ -353,7 +334,7 @@ M: pointer c-type
             "from_unsigned_4" >>boxer
             "to_unsigned_4" >>unboxer
             [ >fixnum ] >>unboxer-quot
-        \ uint define-primitive-type
+        \ uint typedef
 
         <c-type>
             integer >>class
@@ -365,7 +346,8 @@ M: pointer c-type
             8 >>align-first
             "from_signed_cell" >>boxer
             "to_fixnum" >>unboxer
-        \ longlong define-primitive-type
+            [ >integer ] >>unboxer-quot
+        \ longlong typedef
 
         <c-type>
             integer >>class
@@ -377,21 +359,22 @@ M: pointer c-type
             8 >>align-first
             "from_unsigned_cell" >>boxer
             "to_cell" >>unboxer
-        \ ulonglong define-primitive-type
+            [ >integer ] >>unboxer-quot
+        \ ulonglong typedef
 
         os windows? [
-            \ int c-type \ long define-primitive-type
+            \ int lookup-c-type \ long typedef
-            \ uint c-type \ ulong define-primitive-type
+            \ uint lookup-c-type \ ulong typedef
         ] [
-            \ longlong c-type \ long define-primitive-type
+            \ longlong lookup-c-type \ long typedef
-            \ ulonglong c-type \ ulong define-primitive-type
+            \ ulonglong lookup-c-type \ ulong typedef
         ] if
 
-        \ longlong c-type \ ptrdiff_t typedef
+        \ longlong lookup-c-type \ ptrdiff_t typedef
-        \ longlong c-type \ intptr_t typedef
+        \ longlong lookup-c-type \ intptr_t typedef
 
-        \ ulonglong c-type \ uintptr_t typedef
+        \ ulonglong lookup-c-type \ uintptr_t typedef
-        \ ulonglong c-type \ size_t typedef
+        \ ulonglong lookup-c-type \ size_t typedef
     ] [
         <c-type>
             integer >>class
@@ -403,7 +386,8 @@ M: pointer c-type
             4 >>align-first
             "from_signed_cell" >>boxer
             "to_fixnum" >>unboxer
-        \ int define-primitive-type
+            [ >integer ] >>unboxer-quot
+        \ int typedef
     
         <c-type>
             integer >>class
@@ -415,7 +399,8 @@ M: pointer c-type
             4 >>align-first
             "from_unsigned_cell" >>boxer
             "to_cell" >>unboxer
-        \ uint define-primitive-type
+            [ >integer ] >>unboxer-quot
+        \ uint typedef
 
         <long-long-type>
             integer >>class
@@ -426,7 +411,8 @@ M: pointer c-type
             8-byte-alignment
             "from_signed_8" >>boxer
             "to_signed_8" >>unboxer
-        \ longlong define-primitive-type
+            [ >integer ] >>unboxer-quot
+        \ longlong typedef
 
         <long-long-type>
             integer >>class
@@ -437,23 +423,24 @@ M: pointer c-type
             8-byte-alignment
             "from_unsigned_8" >>boxer
             "to_unsigned_8" >>unboxer
-        \ ulonglong define-primitive-type
+            [ >integer ] >>unboxer-quot
+        \ ulonglong typedef
 
-        \ int c-type \ long define-primitive-type
+        \ int lookup-c-type \ long typedef
-        \ uint c-type \ ulong define-primitive-type
+        \ uint lookup-c-type \ ulong typedef
 
-        \ int c-type \ ptrdiff_t typedef
+        \ int lookup-c-type \ ptrdiff_t typedef
-        \ int c-type \ intptr_t typedef
+        \ int lookup-c-type \ intptr_t typedef
 
-        \ uint c-type \ uintptr_t typedef
+        \ uint lookup-c-type \ uintptr_t typedef
-        \ uint c-type \ size_t typedef
+        \ uint lookup-c-type \ size_t typedef
     ] if
 
-    cpu ppc? \ uint \ uchar ? c-type clone
+    \ uchar lookup-c-type clone
         [ >c-bool ] >>unboxer-quot
         [ c-bool> ] >>boxer-quot
         object >>boxed-class
-    \ bool define-primitive-type
+    \ bool typedef
 
 ] with-compilation-unit
 

basis/alien/complex/complex-docs.factor

@@ -0,0 +1,14 @@
+USING: help.markup help.syntax math ;
+IN: alien.complex
+
+HELP: complex-float
+{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link complex } " objects." } ;
+HELP: complex-double
+{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link complex } " objects." } ;
+
+ARTICLE: "alien.complex" "C99 complex number types"
+"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
+{ $table
+    { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link complex } " values" } }
+    { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link complex } " values" } }
+} ;

basis/alien/complex/complex.factor

@@ -10,6 +10,6 @@ IN: alien.complex
 
 <<
 ! This overrides the fact that small structures are never returned
-! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
+! in registers on Linux running on 32-bit x86.
-\ complex-float c-type t >>return-in-registers? drop
+\ complex-float lookup-c-type t >>return-in-registers? drop
 >>

basis/alien/complex/functor/functor.factor

@@ -24,7 +24,7 @@ STRUCT: T-class { real N-type } { imaginary N-type } ;
 : *T ( alien -- z )
     T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
 
-T-class c-type
+T-class lookup-c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
 complex >>boxed-class

basis/alien/data/data-docs.factor

@@ -1,39 +1,43 @@
 USING: alien alien.c-types help.syntax help.markup libc
 kernel.private byte-arrays math strings hashtables alien.syntax
 alien.strings sequences io.encodings.string debugger destructors
-vocabs.loader classes.struct quotations ;
+vocabs.loader classes.struct quotations kernel ;
 IN: alien.data
 
+HELP: >c-array
+{ $values { "seq" sequence } { "c-type" "a C type" } { "array" byte-array } }
+{ $description "Outputs a freshly allocated byte-array whose elements are C type values from the given sequence." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
+
 HELP: <c-array>
 { $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
-{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
 { $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
 
-HELP: <c-object>
+HELP: c-array{
-{ $values { "type" "a C type" } { "array" byte-array } }
+{ $description "Literal syntax, consists of a C-type followed by a series of values terminated by " { $snippet "}" } }
-{ $description "Creates a byte array suitable for holding a value with the given C type." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
-{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
-
-{ <c-object> malloc-object } related-words
 
 HELP: memory>byte-array
 { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
 { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
 
+HELP: cast-array
+{ $values { "byte-array" byte-array } { "c-type" "a C type" } { "array" "a specialized array" } }
+{ $description "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
+
 HELP: malloc-array
-{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
+{ $values { "n" "a non-negative integer" } { "c-type" "a C type" } { "array" "a specialized array" } }
 { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
-{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
 
-HELP: malloc-object
-{ $values { "type" "a C type" } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
-
 HELP: malloc-byte-array
 { $values { "byte-array" byte-array } { "alien" alien } }
 { $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
@@ -62,10 +66,10 @@ classes.struct kernel math math.functions
 prettyprint ;
 IN: scratchpad
 
-STRUCT: point { x int } { y int } ;
+STRUCT: test-point { x int } { y int } ;
 
 : scoped-allocation-test ( -- x )
-    { point } [
+    { test-point } [
         3 >>x 4 >>y
         [ x>> sq ] [ y>> sq ] bi + sqrt
     ] with-scoped-allocation ;
@@ -92,7 +96,6 @@ ARTICLE: "malloc" "Manual memory management"
 $nl
 "Allocating a C datum with a fixed address:"
 { $subsections
-    malloc-object
     malloc-byte-array
 }
 "The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
@@ -134,6 +137,10 @@ ARTICLE: "c-pointers" "Passing pointers to C functions"
 { $warning
 "The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
 
+ARTICLE: "c-boxes" "C value boxes"
+"Sometimes it is useful to create a byte array storing a single C value, like a struct with a single field. A pair of utility macros exist to make this more convenient:"
+{ $subsections <ref> deref } ;
+
 ARTICLE: "c-data" "Passing data between Factor and C"
 "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
 $nl
@@ -144,13 +151,12 @@ $nl
     "malloc"
     "c-strings"
     "c-out-params"
+    "c-boxes"
 }
 "Important guidelines for passing data in byte arrays:"
 { $subsections "byte-arrays-gc" }
 "C-style enumerated types are supported:"
-{ $subsections "alien.enums" POSTPONE: ENUM: }
+{ $subsections "alien.enums" }
-"C types can be aliased for convenience and consistency with native library documentation:"
-{ $subsections POSTPONE: TYPEDEF: }
 "A utility for defining " { $link "destructors" } " for deallocating memory:"
 { $subsections "alien.destructors" }
 "C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
@@ -167,15 +173,10 @@ HELP: malloc-string
     }
 } ;
 
-HELP: require-c-array
-{ $values { "c-type" "a C type" } }
-{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
-{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
-
 HELP: <c-direct-array>
 { $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
 { $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
-{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
 
 ARTICLE: "c-strings" "C strings"
 "C string types are arrays with shape " { $snippet "{ c-string encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link c-string } " is an alias for " { $snippet "{ c-string utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors. In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, the shorthand syntax " { $snippet "c-string[encoding]" } " can be used to specify the string encoding."
@@ -199,3 +200,20 @@ $nl
 { $subsections alien>string }
 "For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;
 
+HELP: <ref>
+{ $values { "value" object } { "c-type" "a C type" } { "c-ptr" c-ptr } }
+{ $description "Creates a new byte array to store a Factor object as a C value." }
+{ $examples
+    { $example "USING: alien.c-types alien.data prettyprint sequences ;" "123 int <ref> length ." "4" }
+} ;
+
+HELP: deref
+{ $values { "c-ptr" c-ptr } { "c-type" "a C type" } { "value" object } }
+{ $description "Loads a C value from a byte array." }
+{ $examples
+    { $example "USING: alien.c-types alien.data prettyprint sequences ;" "321 int <ref> int deref ." "321" }
+} ;
+
+ARTICLE: "c-out-params" "Output parameters in C"
+"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
+{ $subsection with-out-parameters } ;

basis/alien/data/data-tests.factor

@@ -1,9 +1,32 @@
-USING: alien alien.c-types alien.data alien.syntax
+USING: alien alien.data alien.syntax
 classes.struct kernel sequences specialized-arrays
-specialized-arrays.private tools.test compiler.units vocabs ;
+specialized-arrays.private tools.test compiler.units vocabs
+system ;
+QUALIFIED-WITH: alien.c-types c
 IN: alien.data.tests
 
-STRUCT: foo { a int } { b void* } { c bool } ;
+[ -1 ] [ -1 c:char <ref> c:char deref ] unit-test
+[ -1 ] [ -1 c:short <ref> c:short deref ] unit-test
+[ -1 ] [ -1 c:int <ref> c:int deref ] unit-test
+
+! I don't care if this throws an error or works, but at least
+! it should be consistent between platforms
+[ -1 ] [ -1.0 c:int <ref> c:int deref ] unit-test
+[ -1 ] [ -1.0 c:long <ref> c:long deref ] unit-test
+[ -1 ] [ -1.0 c:longlong <ref> c:longlong deref ] unit-test
+[ 1 ] [ 1.0 c:uint <ref> c:uint deref ] unit-test
+[ 1 ] [ 1.0 c:ulong <ref> c:ulong deref ] unit-test
+[ 1 ] [ 1.0 c:ulonglong <ref> c:ulonglong deref ] unit-test
+
+[
+    0 B{ 1 2 3 4 } <displaced-alien> c:void* <ref>
+] must-fail
+
+os windows? cpu x86.64? and [
+    [ -2147467259 ] [ 2147500037 c:long <ref> c:long deref ] unit-test
+] when
+
+STRUCT: foo { a c:int } { b c:void* } { c c:bool } ;
 
 SPECIALIZED-ARRAY: foo
 

basis/alien/data/data.factor

@@ -1,15 +1,20 @@
 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.arrays alien.strings
+USING: accessors alien alien.arrays alien.c-types alien.strings
-arrays byte-arrays cpu.architecture fry io io.encodings.binary
+arrays byte-arrays combinators combinators.short-circuit
-io.files io.streams.memory kernel libc math math.functions 
+cpu.architecture fry generalizations io io.streams.memory kernel
-sequences words macros combinators generalizations
+libc locals macros math math.functions parser sequences
-stack-checker.dependencies combinators.short-circuit ;
+stack-checker.dependencies summary words ;
 QUALIFIED: math
 IN: alien.data
 
-GENERIC: require-c-array ( c-type -- )
+: <ref> ( value c-type -- c-ptr )
+    [ heap-size <byte-array> ] keep
+    '[ 0 _ set-alien-value ] keep ; inline
 
-M: array require-c-array first require-c-array ;
+: deref ( c-ptr c-type -- value )
+    [ 0 ] dip alien-value ; inline
+
+: little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
 
 GENERIC: c-array-constructor ( c-type -- word ) foldable
 
@@ -17,6 +22,26 @@ GENERIC: c-(array)-constructor ( c-type -- word ) foldable
 
 GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
 
+GENERIC: c-array-type ( c-type -- word ) foldable
+
+GENERIC: c-array-type? ( c-type -- word ) foldable
+
+GENERIC: c-array? ( obj c-type -- ? ) foldable
+
+M: word c-array?
+    c-array-type? execute( seq -- array ) ; inline
+
+M: pointer c-array?
+    drop void* c-array? ;
+
+GENERIC: >c-array ( seq c-type -- array )
+
+M: word >c-array
+    c-array-type new clone-like ; inline
+
+M: pointer >c-array
+    drop void* >c-array ;
+
 GENERIC: <c-array> ( len c-type -- array )
 
 M: word <c-array>
@@ -41,24 +66,24 @@ M: word <c-direct-array>
 M: pointer <c-direct-array>
     drop void* <c-direct-array> ;
 
-: malloc-array ( n type -- array )
+SYNTAX: c-array{ \ } [ unclip >c-array ] parse-literal ;
+
+SYNTAX: c-array@
+    scan-object [ scan-object scan-object ] dip
+    <c-direct-array> suffix! ;
+
+ERROR: bad-byte-array-length byte-array type ;
+
+M: bad-byte-array-length summary
+    drop "Byte array length doesn't divide type width" ;
+
+: cast-array ( byte-array c-type -- array )
+    [ binary-object ] dip [ heap-size /mod 0 = ] keep swap
+    [ <c-direct-array> ] [ bad-byte-array-length ] if ; inline
+
+: malloc-array ( n c-type -- array )
     [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
 
-: (malloc-array) ( n type -- alien )
-    [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
-
-: <c-object> ( type -- array )
-    heap-size <byte-array> ; inline
-
-: (c-object) ( type -- array )
-    heap-size (byte-array) ; inline
-
-: malloc-object ( type -- alien )
-    1 swap heap-size calloc ; inline
-
-: (malloc-object) ( type -- alien )
-    heap-size malloc ; inline
-
 : malloc-byte-array ( byte-array -- alien )
     binary-object [ nip malloc dup ] 2keep memcpy ;
 
@@ -68,11 +93,11 @@ M: pointer <c-direct-array>
 : malloc-string ( string encoding -- alien )
     string>alien malloc-byte-array ;
 
-M: memory-stream stream-read
+M:: memory-stream stream-read-unsafe ( n buf stream -- count )
-    [
+    stream alien>> :> src
-        [ index>> ] [ alien>> ] bi <displaced-alien>
+    buf src n memcpy
-        swap memory>byte-array
+    n src <displaced-alien> stream alien<<
-    ] [ [ + ] change-index drop ] 2bi ;
+    n ; inline
 
 M: value-type c-type-rep drop int-rep ;
 
@@ -102,7 +127,7 @@ ERROR: local-allocation-error ;
     ;
 
 MACRO: (simple-local-allot) ( c-type -- quot )
-    [ depends-on-c-type ]
+    [ add-depends-on-c-type ]
     [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
 
 : [hairy-local-allot] ( c-type initial -- quot )

basis/alien/endian/endian-docs.factor

@@ -0,0 +1,150 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel math quotations
+classes.struct ;
+IN: alien.endian
+
+HELP: BE-PACKED-STRUCT:
+{ $description "Defines a packed " { $link struct } " where endian-unaware types become big-endian types. Note that endian-aware types will override the big-endianness of this " { $link struct } " declaration; little-endian types will stay little-endian. On big-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
+{ $unchecked-example
+    "! When run on a big-endian platform, this struct should prettyprint the same as defined"
+    "! The output of this example is from a little-endian platform"
+    "USE: alien.endian"
+    "BE-PACKED-STRUCT: s1 { a char[7] } { b int } ;"
+    "\\ s1 see"
+    "USING: alien.c-types alien.endian classes.struct ;
+IN: scratchpad
+STRUCT: s1 { a char[7] } { b be32 initial: 0 } ;"
+} ;
+
+HELP: BE-STRUCT:
+{ $description "Defines a " { $link struct } " where endian-unaware types become big-endian types. Note that endian-aware types will override the big-endianness of this " { $link struct } " declaration; little-endian types will stay little-endian. On big-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
+{ $unchecked-example
+    "! When run on a big-endian platform, this struct should prettyprint the same as defined"
+    "! The output of this example is from a little-endian platform"
+    "USE: alien.endian"
+    "BE-STRUCT: s1 { a int } { b le32 } ;"
+    "\\ s1 see"
+    "USING: alien.c-types alien.endian classes.struct ;
+IN: scratchpad
+STRUCT: s1 { a be32 initial: 0 } { b le32 initial: 0 } ;"
+} ;
+
+HELP: LE-PACKED-STRUCT:
+{ $description "Defines a packed " { $link struct } " where endian-unaware types become little-endian types. Note that endian-aware types will override the little-endianness of this " { $link struct } " declaration; big-endian types will stay big-endian. On little-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
+{ $unchecked-example
+    "! When run on a little-endian platform, this struct should prettyprint the same as defined"
+    "! The output of this example is from a little-endian platform"
+    "USE: alien.endian"
+    "LE-PACKED-STRUCT: s1 { a char[7] } { b int } ;"
+    "\\ s1 see"
+    "USING: alien.c-types alien.endian classes.struct ;
+IN: scratchpad
+STRUCT: s1 { a char[7] } { b int initial: 0 } ;"
+} ;
+
+HELP: LE-STRUCT:
+{ $description "Defines a " { $link struct } " where endian-unaware types become little-endian types. Note that endian-aware types will override the little-endianness of this " { $link struct } " declaration; big-endian types will stay big-endian. On little-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
+{ $unchecked-example
+    "! When run on a little-endian platform, this struct should prettyprint the same as defined"
+    "! The output of this example is from a little-endian platform"
+    "USE: alien.endian"
+    "LE-STRUCT: s1 { a int } { b be32 } ;"
+    "\\ s1 see"
+    "USING: alien.c-types alien.endian classes.struct ;
+IN: scratchpad
+STRUCT: s1 { a int initial: 0 } { b be32 initial: 0 } ;"
+} ;
+
+HELP: be16
+{ $var-description "Signed bit-endian 16-bit." } ;
+
+HELP: be32
+{ $var-description "Signed bit-endian 32-bit." } ;
+
+HELP: be64
+{ $var-description "Signed bit-endian 64-bit." } ;
+
+HELP: be8
+{ $var-description "Signed bit-endian 8-bit." } ;
+
+HELP: byte-reverse
+{ $values
+    { "n" integer } { "signed?" boolean }
+    { "quot" quotation }
+}
+{ $description "Reverses the " { $snippet "n" } " bytes in an integer with bitwise operations. The second parameter only works for 1, 2, 4, or 8 byte signed numbers." } ;
+
+HELP: le16
+{ $var-description "Signed little-endian 16-bit." } ;
+
+HELP: le32
+{ $var-description "Signed little-endian 32-bit." } ;
+
+HELP: le64
+{ $var-description "Signed little-endian 64-bit." } ;
+
+HELP: le8
+{ $var-description "Signed little-endian 8-bit." } ;
+
+HELP: ube16
+{ $var-description "Unsigned big-endian 16-bit." } ;
+
+HELP: ube32
+{ $var-description "Unsigned big-endian 32-bit." } ;
+
+HELP: ube64
+{ $var-description "Unsigned big-endian 64-bit." } ;
+
+HELP: ube8
+{ $var-description "Unsigned big-endian 8-bit." } ;
+
+HELP: ule16
+{ $var-description "Unsigned little-endian 16-bit." } ;
+
+HELP: ule32
+{ $var-description "Unsigned little-endian 32-bit." } ;
+
+HELP: ule64
+{ $var-description "Unsigned little-endian 64-bit." } ;
+
+HELP: ule8
+{ $var-description "Unsigned little-endian 8-bit." } ;
+
+ARTICLE: "alien.endian" "Alien endian-aware types"
+"The " { $vocab-link "alien.endian" } " vocabulary defines c-types that are endian-aware for use in structs. These types will cause the bytes in a byte-array to be interpreted as little or big-endian transparently when reading or writing. There are both signed and unsigned types defined; signed is the default while unsigned are prefixed with a " { $snippet "u" } ". The intended use-case is for network protocols in network-byte-order (big-endian)." $nl
+"Byte-reversal of integers:"
+{ $subsections
+    byte-reverse
+}
+"The big-endian c-types are:"
+{ $subsections
+    be8
+    be16
+    be32
+    be64
+    ube8
+    ube16
+    ube32
+    ube64
+}
+"The little-endian c-types are:"
+{ $subsections
+    le8
+    le16
+    le32
+    le64
+    ule8
+    ule16
+    ule32
+    ule64
+}
+"Syntax for making endian-aware structs out of native types:"
+{ $subsections
+    POSTPONE: LE-STRUCT:
+    POSTPONE: BE-STRUCT:
+    POSTPONE: LE-PACKED-STRUCT:
+    POSTPONE: BE-PACKED-STRUCT:
+} ;
+
+ABOUT: "alien.endian"

basis/alien/endian/endian-tests.factor

@@ -0,0 +1,241 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.endian classes.struct io
+io.encodings.binary io.streams.byte-array kernel tools.test
+alien.c-types ;
+IN: alien.endian.tests
+
+STRUCT: endian-struct
+    { a ule16 }
+    { b le16 }
+    { c ube16 }
+    { d be16 }
+    { e ule32 }
+    { f le32 }
+    { g ube32 }
+    { h be32 }
+    { i ule64 }
+    { j le64 }
+    { k ube64 }
+    { l be64 } ;
+
+CONSTANT: endian-bytes-0f B{
+        0x0 0xff
+        0x0 0xff
+        0x0 0xff
+        0x0 0xff
+
+        0x0 0x0 0x0 0xff
+        0x0 0x0 0x0 0xff
+        0x0 0x0 0x0 0xff
+        0x0 0x0 0x0 0xff
+
+        0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
+        0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
+        0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
+        0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
+    }
+
+CONSTANT: endian-bytes-f0 B{
+        0xff 0x0
+        0xff 0x0
+        0xff 0x0
+        0xff 0x0
+
+        0xff 0x0 0x0 0x0
+        0xff 0x0 0x0 0x0
+        0xff 0x0 0x0 0x0
+        0xff 0x0 0x0 0x0
+
+        0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
+        0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
+        0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
+        0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
+    }
+
+: endian-test-struct-0f ( -- obj )
+    endian-bytes-0f endian-struct memory>struct ;
+
+: endian-test-struct-f0 ( -- obj )
+    endian-bytes-f0 endian-struct memory>struct ;
+
+[ 0xff00 ] [ endian-test-struct-0f a>> ] unit-test
+[ -256 ] [ endian-test-struct-0f b>> ] unit-test
+[ 0x00ff ] [ endian-test-struct-0f c>> ] unit-test
+[ 0x00ff ] [ endian-test-struct-0f d>> ] unit-test
+
+[ 0xff000000 ] [ endian-test-struct-0f e>> ] unit-test
+[ -16777216 ] [ endian-test-struct-0f f>> ] unit-test
+[ 0x000000ff ] [ endian-test-struct-0f g>> ] unit-test
+[ 0x000000ff ] [ endian-test-struct-0f h>> ] unit-test
+
+[ 0xff00000000000000 ] [ endian-test-struct-0f i>> ] unit-test
+[ -72057594037927936 ] [ endian-test-struct-0f j>> ] unit-test
+[ 0x00000000000000ff ] [ endian-test-struct-0f k>> ] unit-test
+[ 0x00000000000000ff ] [ endian-test-struct-0f l>> ] unit-test
+
+
+[ 0xff00 ] [ endian-test-struct-f0 c>> ] unit-test
+[ -256 ] [ endian-test-struct-f0 d>> ] unit-test
+[ 0x00ff ] [ endian-test-struct-f0 a>> ] unit-test
+[ 0x00ff ] [ endian-test-struct-f0 b>> ] unit-test
+
+[ 0xff000000 ] [ endian-test-struct-f0 g>> ] unit-test
+[ -16777216 ] [ endian-test-struct-f0 h>> ] unit-test
+[ 0x000000ff ] [ endian-test-struct-f0 e>> ] unit-test
+[ 0x000000ff ] [ endian-test-struct-f0 f>> ] unit-test
+
+[ 0xff00000000000000 ] [ endian-test-struct-f0 k>> ] unit-test
+[ -72057594037927936 ] [ endian-test-struct-f0 l>> ] unit-test
+[ 0x00000000000000ff ] [ endian-test-struct-f0 i>> ] unit-test
+[ 0x00000000000000ff ] [ endian-test-struct-f0 j>> ] unit-test
+
+[ t ]
+[ endian-test-struct-0f binary [ write ] with-byte-writer endian-bytes-0f = ] unit-test
+
+[ t ]
+[ endian-test-struct-f0 binary [ write ] with-byte-writer endian-bytes-f0 = ] unit-test
+
+LE-STRUCT: le-endian-struct
+    { a ule16 }
+    { b le16 }
+    { c ube16 }
+    { d be16 }
+    { e ule32 }
+    { f le32 }
+    { g ube32 }
+    { h be32 }
+    { i ule64 }
+    { j le64 }
+    { k ube64 }
+    { l be64 } ;
+
+[ t ]
+[
+    endian-bytes-0f le-endian-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-0f =
+] unit-test
+
+[ t ]
+[
+    endian-bytes-f0 le-endian-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-f0 =
+] unit-test
+
+
+BE-STRUCT: be-endian-struct
+    { a ule16 }
+    { b le16 }
+    { c ube16 }
+    { d be16 }
+    { e ule32 }
+    { f le32 }
+    { g ube32 }
+    { h be32 }
+    { i ule64 }
+    { j le64 }
+    { k ube64 }
+    { l be64 } ;
+
+[ t ]
+[
+    endian-bytes-0f be-endian-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-0f =
+] unit-test
+
+[ t ]
+[
+    endian-bytes-f0 be-endian-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-f0 =
+] unit-test
+
+LE-STRUCT: le-override-struct
+    { a ushort }
+    { b short }
+    { c ube16 }
+    { d be16 }
+    { e uint }
+    { f int }
+    { g ube32 }
+    { h be32 }
+    { i ulonglong }
+    { j longlong }
+    { k ube64 }
+    { l be64 } ;
+
+[ t ]
+[
+    endian-bytes-0f le-override-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-0f =
+] unit-test
+
+[ t ]
+[
+    endian-bytes-f0 le-override-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-f0 =
+] unit-test
+
+BE-STRUCT: be-override-struct
+    { a ule16 }
+    { b le16 }
+    { c ushort }
+    { d short }
+    { e ule32 }
+    { f le32 }
+    { g uint }
+    { h int }
+    { i ule64 }
+    { j le64 }
+    { k ulonglong }
+    { l longlong } ;
+
+[ t ]
+[
+    endian-bytes-0f be-override-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-0f =
+] unit-test
+
+[ t ]
+[
+    endian-bytes-f0 be-override-struct memory>struct
+    binary [ write ] with-byte-writer endian-bytes-f0 =
+] unit-test
+
+
+LE-PACKED-STRUCT: le-packed-struct
+    { a char[7] }
+    { b int } ;
+
+[ t ]
+[
+    B{ 0 0 0 0 0 0 0  3 0 0 0 } [
+        le-packed-struct memory>struct
+        binary [ write ] with-byte-writer
+    ] keep =
+] unit-test
+
+[ 3 ]
+[
+    B{ 0 0 0 0 0 0 0  3 0 0 0 } le-packed-struct memory>struct
+    b>>
+] unit-test
+
+
+BE-PACKED-STRUCT: be-packed-struct
+    { a char[7] }
+    { b int } ;
+
+[ t ]
+[
+    B{ 0 0 0 0 0 0 0  0 0 0 3 } [
+        be-packed-struct memory>struct
+        binary [ write ] with-byte-writer
+    ] keep =
+] unit-test
+
+[ 3 ]
+[
+    B{ 0 0 0 0 0 0 0  0 0 0 3 } be-packed-struct memory>struct
+    b>>
+] unit-test
+

basis/alien/endian/endian.factor

@@ -0,0 +1,163 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors alien.c-types alien.data
+classes.struct.private combinators compiler.units endian fry
+generalizations kernel macros math namespaces sequences words
+arrays slots math.bitwise ;
+QUALIFIED-WITH: alien.c-types ac
+IN: alien.endian
+
+ERROR: invalid-signed-conversion n ;
+
+: convert-signed-quot ( n -- quot )
+    {
+        { 1 [ [ char <ref> char deref ] ] }
+        { 2 [ [ ac:short <ref> ac:short deref ] ] }
+        { 4 [ [ int <ref> int deref ] ] }
+        { 8 [ [ longlong <ref> longlong deref ] ] }
+        [ invalid-signed-conversion ]
+    } case ; inline
+
+MACRO: byte-reverse ( n signed? -- quot )
+    [
+        drop
+        [
+            dup iota [
+                [ 1 + - -8 * ] [ nip 8 * ] 2bi
+                '[ _ shift 0xff bitand _ shift ]
+            ] with map
+        ] [ 1 - [ bitor ] n*quot ] bi
+    ] [
+        [ convert-signed-quot ] [ drop [ ] ] if
+    ] 2bi
+    '[ _ cleave @ @ ] ;
+
+SYMBOLS: le8 be8 ule8 ube8
+ule16 ule32 ule64 ube16 ube32 ube64
+le16 le32 le64 be16 be32 be64 ;
+
+: endian-c-type? ( symbol -- ? )
+    {
+        le8 be8 ule8 ube8 ule16 ule32 ule64
+        ube16 ube32 ube64 le16 le32 le64 be16 be32 be64
+    } member? ;
+
+ERROR: unknown-endian-c-type symbol ;
+
+: endian-c-type>c-type-symbol ( symbol -- symbol' )
+    {
+        { [ dup { ule16 ube16 } member? ] [ drop ushort ] }
+        { [ dup { le16 be16 } member? ] [ drop ac:short ] }
+        { [ dup { ule32 ube32 } member? ] [ drop uint ] }
+        { [ dup { le32 be32 } member? ] [ drop int ] }
+        { [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
+        { [ dup { le64 be64 } member? ] [ drop longlong ] }
+        [ unknown-endian-c-type ]
+    } cond ;
+
+: change-c-type-accessors ( n ? c-type -- c-type' )
+    endian-c-type>c-type-symbol "c-type" word-prop clone
+    -rot over 8 = [
+        [
+            nip
+            [
+                [
+                    [ alien-unsigned-4 4 f byte-reverse 32 shift ]
+                    [ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor
+                ]
+            ] dip [ [ 64 >signed ] compose ] when 
+            >>getter drop
+        ]
+        [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
+    ] [
+        [ '[ [ _ _ byte-reverse ] compose ] change-getter drop ]
+        [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
+    ] if ;
+
+: typedef-endian ( n ? c-type endian -- )
+    native-endianness get = [
+        2nip [ endian-c-type>c-type-symbol ] keep typedef
+    ] [
+        [ change-c-type-accessors ] keep typedef
+    ] if ;
+
+: typedef-le ( n ? c-type -- ) little-endian typedef-endian ;
+: typedef-be ( n ? c-type -- ) big-endian typedef-endian ;
+
+[
+    \ char \ le8 typedef
+    \ char \ be8 typedef
+    \ uchar \ ule8 typedef
+    \ uchar \ ube8 typedef
+    2 f \ ule16 typedef-le
+    2 f \ ube16 typedef-be
+    2 t \ le16 typedef-le
+    2 t \ be16 typedef-be
+    4 f \ ule32 typedef-le
+    4 f \ ube32 typedef-be
+    4 t \ le32 typedef-le
+    4 t \ be32 typedef-be
+    8 f \ ule64 typedef-le
+    8 f \ ube64 typedef-be
+    8 t \ le64 typedef-le
+    8 t \ be64 typedef-be
+] with-compilation-unit
+
+! pair: { le be }
+: pair>c-type ( pair -- c-type )
+    [ native-endianness get big-endian = ] dip first2 ? ;
+
+! endian is desired endian type. if we match endianness, return the c type
+! otherwise return the opposite of our endianness
+: endian-slot ( endian c-type pair -- endian-slot )
+    [ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ;
+    
+ERROR: unsupported-endian-type endian slot ;
+
+: slot>endian-slot ( endian slot -- endian-slot )
+    dup array? [
+        first2 [ slot>endian-slot ] dip 2array
+    ] [
+        {
+            { [ dup char = ] [ 2drop char ] }
+            { [ dup uchar = ] [ 2drop uchar ] }
+            { [ dup ac:short = ] [ { le16 be16 } endian-slot ] }
+            { [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
+            { [ dup int = ] [ { le32 be32 } endian-slot ] }
+            { [ dup uint = ] [ { ule32 ube32 } endian-slot ] }
+            { [ dup longlong = ] [ { le64 be64 } endian-slot ] }
+            { [ dup ulonglong = ] [ { ule64 ube64 } endian-slot ] }
+            { [ dup endian-c-type? ] [ nip ] }
+            [ unsupported-endian-type ]
+        } cond
+    ] if ;
+
+: set-endian-slots ( endian slots -- slot-specs )
+    [ [ slot>endian-slot ] change-type ] with map ;
+
+: define-endian-struct-class ( class slots endian -- )
+    swap make-slots set-endian-slots
+    [ compute-struct-offsets ] [ struct-alignment ]
+    (define-struct-class) ;
+
+: define-endian-packed-struct-class ( class slots endian -- )
+    swap make-packed-slots set-endian-slots
+    [ compute-struct-offsets ] [ drop 1 ]
+    (define-struct-class) ;
+
+SYNTAX: LE-STRUCT:
+    parse-struct-definition
+    little-endian define-endian-struct-class ;
+
+SYNTAX: BE-STRUCT:
+    parse-struct-definition
+    big-endian define-endian-struct-class ;
+
+SYNTAX: LE-PACKED-STRUCT:
+    parse-struct-definition
+    little-endian define-endian-packed-struct-class ;
+
+SYNTAX: BE-PACKED-STRUCT:
+    parse-struct-definition
+    big-endian define-endian-packed-struct-class ;
+

basis/alien/enums/enums-docs.factor

@@ -23,14 +23,6 @@ HELP: number>enum
 }
 { $description "Convert a number to an enum." } ;
 
-ARTICLE: "alien.enums" "Enumeration types"
-"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers."
-$nl
-"Defining enums at run-time:"
-{ $subsection define-enum }
-"Conversions between enums and integers:"
-{ $subsections enum>number number>enum } ;
-
 { POSTPONE: ENUM: define-enum enum>number number>enum } related-words
 
 ABOUT: "alien.enums"

basis/alien/enums/enums-tests.factor

@@ -33,3 +33,19 @@ ENUM: instrument_t < ushort trombone trumpet ;
 
 { V{ { red 0 } { green 3 } { blue 4 } } }
 [ color_t "c-type" word-prop members>> ] unit-test
+
+ENUM: colores { rojo red } { verde green } { azul blue } { colorado rojo } ;
+
+[ { 0 3 4 0 } ] [ { rojo verde azul colorado } [ enum>number ] map ] unit-test
+
+SYMBOLS: couleurs rouge vert bleu jaune azure ;
+
+<< \ couleurs int {
+    { rouge red }
+    { vert green }
+    { bleu blue }
+    { jaune 14 }
+    { azure bleu }
+} define-enum >>
+
+[ { 0 3 4 14 4 } ] [ { rouge vert bleu jaune azure } [ enum>number ] map ] unit-test

basis/alien/enums/enums.factor

@@ -1,6 +1,7 @@
 ! (c)2010 Joe Groff, Erik Charlebois bsd license
 USING: accessors alien.c-types arrays combinators delegate fry
-generic.parser kernel macros math parser sequences words words.symbol ;
+generic.parser kernel macros math parser sequences words words.symbol
+classes.singleton assocs ;
 IN: alien.enums
 
 <PRIVATE
@@ -12,7 +13,7 @@ PRIVATE>
 
 GENERIC: enum>number ( enum -- number ) foldable
 M: integer enum>number ;
-M: symbol enum>number "enum-value" word-prop ;
+M: word enum>number "enum-value" word-prop ;
 
 <PRIVATE
 : enum-boxer ( members -- quot )
@@ -21,7 +22,7 @@ M: symbol enum>number "enum-value" word-prop ;
 PRIVATE>
 
 MACRO: number>enum ( enum-c-type -- )
-    c-type members>> enum-boxer ;
+    lookup-c-type members>> enum-boxer ;
 
 M: enum-c-type c-type-boxed-class drop object ;
 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
@@ -29,27 +30,28 @@ M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
 M: enum-c-type c-type-setter
    [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
 
+: define-enum-value ( class value -- )
+    enum>number "enum-value" set-word-prop ;
+
 <PRIVATE
 
-: define-enum-value ( class value -- )
+: define-enum-members ( members -- )
-    "enum-value" set-word-prop ;
+    [ first define-singleton-class ] each ;
-
-: define-enum-members ( member-names -- )
-    [
-        [ first define-symbol ]
-        [ first2 define-enum-value ] bi
-    ] each ;
 
 : define-enum-constructor ( word -- )
     [ name>> "<" ">" surround create-in ] keep
-    [ number>enum ] curry (( number -- enum )) define-inline ;
+    [ number>enum ] curry ( number -- enum ) define-inline ;
 
 PRIVATE>
 
-: define-enum ( word base-type members -- )
+: (define-enum) ( word base-type members -- )
     [ dup define-enum-constructor ] 2dip
-    dup define-enum-members
+    [ define-enum-members ]
-    <enum-c-type> swap typedef ;
+    [ <enum-c-type> swap typedef ] bi ;
+
+: define-enum ( word base-type members -- )
+    [ (define-enum) ]
+    [ [ define-enum-value ] assoc-each ] bi ;
     
 PREDICATE: enum-c-type-word < c-type-word
     "c-type" word-prop enum-c-type? ;

basis/alien/libraries/libraries-docs.factor

@@ -24,17 +24,17 @@ HELP: library
     }
 } ;
 
-HELP: dlopen ( path -- dll )
+HELP: dlopen
 { $values { "path" "a pathname string" } { "dll" "a DLL handle" } }
 { $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." }
 { $errors "Throws an error if the library could not be found, or if loading fails for some other reason." }
 { $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ;
 
-HELP: dlsym ( name dll -- alien )
+HELP: dlsym
 { $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" { $maybe alien } } }
 { $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable. If the symbol was not found, outputs " { $link f } "." } ;
 
-HELP: dlclose ( dll -- )
+HELP: dlclose
 { $values { "dll" "a DLL handle" } }
 { $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
 

basis/alien/libraries/libraries-tests.factor

@@ -1,4 +1,4 @@
-USING: alien.libraries alien.syntax tools.test kernel ;
+USING: alien alien.libraries alien.syntax tools.test kernel ;
 IN: alien.libraries.tests
 
 [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
@@ -8,3 +8,21 @@ IN: alien.libraries.tests
 [ ] [ "doesnotexist" dlopen dlclose ] unit-test
 
 [ "fdasfsf" dll-valid? drop ] must-fail
+
+[ t ] [
+    "test-library" "blah" cdecl add-library
+    "test-library" "BLAH" cdecl add-library?
+    "blah" remove-library
+] unit-test
+
+[ t ] [
+    "test-library" "blah" cdecl add-library
+    "test-library" "blah" stdcall add-library?
+    "blah" remove-library
+] unit-test
+
+[ f ] [
+    "test-library" "blah" cdecl add-library
+    "test-library" "blah" cdecl add-library?
+    "blah" remove-library
+] unit-test

basis/alien/libraries/libraries.factor

@@ -2,28 +2,37 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.strings assocs io.backend
 kernel namespaces destructors sequences strings
-system io.pathnames ;
+system io.pathnames fry combinators vocabs ;
 IN: alien.libraries
 
 : dlopen ( path -- dll ) native-string>alien (dlopen) ;
 
 : dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
 
+: dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ;
+
+HOOK: dlerror os ( -- message/f )
+
 SYMBOL: libraries
 
 libraries [ H{ } clone ] initialize
 
-TUPLE: library { path string } { abi abi initial: cdecl } dll ;
+TUPLE: library { path string } { abi abi initial: cdecl } dll dlerror ;
 
 ERROR: no-library name ;
 
 : library ( name -- library ) libraries get at ;
 
 : <library> ( path abi -- library )
-    over dup [ dlopen ] when \ library boa ;
+    over dup
+    [ dlopen dup dll-valid? [ f ] [ dlerror ] if ] [ f ] if
+    \ library boa ;
+
+: library-dll ( library -- dll )
+    dup [ dll>> ] when ;
 
 : load-library ( name -- dll )
-    library dup [ dll>> ] when ;
+    library library-dll ;
 
 M: dll dispose dlclose ;
 
@@ -32,9 +41,15 @@ M: library dispose dll>> [ dispose ] when* ;
 : remove-library ( name -- )
     libraries get delete-at* [ dispose ] [ drop ] if ;
 
+: add-library? ( name path abi -- ? )
+    [ library ] 2dip
+    '[ [ path>> _ = ] [ abi>> _ = ] bi and not ] [ t ] if* ;
+
 : add-library ( name path abi -- )
+    3dup add-library? [
         [ 2drop remove-library ]
-    [ <library> swap libraries get set-at ] 3bi ;
+        [ <library> swap libraries get set-at ] 3bi
+    ] [ 3drop ] if ;
 
 : library-abi ( library -- abi )
     library [ abi>> ] [ cdecl ] if* ;
@@ -42,7 +57,7 @@ M: library dispose dll>> [ dispose ] when* ;
 ERROR: no-such-symbol name library ;
 
 : address-of ( name library -- value )
-    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
+    2dup load-library dlsym-raw [ 2nip ] [ no-such-symbol ] if* ;
 
 SYMBOL: deploy-libraries
 
@@ -53,17 +68,9 @@ deploy-libraries [ V{ } clone ] initialize
     [ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
     [ no-library ] if ;
 
-<PRIVATE
-
 HOOK: >deployed-library-path os ( path -- path' )
 
-M: windows >deployed-library-path
+<< {
-    file-name ;
+    { [ os windows? ] [ "alien.libraries.windows" ] }
-
+    { [ os unix? ] [ "alien.libraries.unix" ] }
-M: unix >deployed-library-path
+} cond require >>
-    file-name "$ORIGIN" prepend-path ;
-
-M: macosx >deployed-library-path
-    file-name "@executable_path/../Frameworks" prepend-path ;
-
-PRIVATE>

basis/alien/libraries/unix/unix.factor

@@ -0,0 +1,15 @@
+USING: alien.c-types alien.libraries alien io.encodings.utf8
+io.pathnames system ;
+IN: alien.libraries.unix
+
+: (dlerror) ( -- string )
+    \ c-string f "dlerror" { } alien-invoke ; inline
+
+M: unix dlerror (dlerror) ;
+
+M: unix >deployed-library-path
+    file-name "$ORIGIN" prepend-path ;
+
+M: macosx >deployed-library-path
+    file-name "@executable_path/../Frameworks" prepend-path ;
+

basis/alien/libraries/windows/windows.factor

@@ -0,0 +1,8 @@
+USING: alien.libraries io.pathnames system windows.errors ;
+IN: alien.libraries.windows
+
+M: windows >deployed-library-path
+    file-name ;
+
+M: windows dlerror ( -- message )
+    win32-error-string ;

basis/alien/parser/parser-tests.factor

@@ -38,7 +38,7 @@ CONSTANT: eleven 11
 
 FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
 
-[ (( arg1 arg2 -- void* )) ] [
+[ ( arg1 arg2 -- void* ) ] [
     \ alien-parser-function-effect-test "declared-effect" word-prop
 ] unit-test
 
@@ -46,7 +46,7 @@ FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
 
 FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
 
-[ (( arg1 arg2 -- void* )) ] [
+[ ( arg1 arg2 -- void* ) ] [
     \ (alien-parser-function-effect-test) "declared-effect" word-prop
 ] unit-test
 
@@ -54,7 +54,7 @@ FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function-
 
 CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ;
 
-[ (( arg1 arg2 -- void* )) ] [
+[ ( arg1 arg2 -- void* ) ] [
     \ alien-parser-callback-effect-test "callback-effect" word-prop
 ] unit-test
 

basis/alien/parser/parser.factor

@@ -4,21 +4,18 @@ USING: accessors alien alien.c-types alien.libraries arrays
 assocs classes combinators combinators.short-circuit
 compiler.units effects grouping kernel parser sequences
 splitting words fry locals lexer namespaces summary math
-vocabs.parser words.constant ;
+vocabs.parser words.constant classes.parser alien.enums ;
 IN: alien.parser
 
 SYMBOL: current-library
 
-: parse-c-type-name ( name -- word )
-    dup search [ ] [ no-word ] ?if ;
-
 DEFER: (parse-c-type)
 
 ERROR: bad-array-type ;
 
 : parse-array-type ( name -- c-type )
     "[" split unclip
-    [ [ "]" ?tail [ bad-array-type ] unless parse-word ] map ]
+    [ [ "]" ?tail [ bad-array-type ] unless parse-datum ] map ]
     [ (parse-c-type) ]
     bi* prefix ;
 
@@ -26,8 +23,8 @@ ERROR: bad-array-type ;
     {
         { [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
         { [ CHAR: ] over member? ] [ parse-array-type ] }
-        { [ dup search ] [ parse-c-type-name ] }
+        { [ dup search ] [ parse-word ] }
-        [ dup search [ ] [ no-word ] ?if ]
+        [ parse-word ]
     } cond ;
 
 : c-array? ( c-type -- ? )
@@ -70,7 +67,7 @@ ERROR: *-in-c-type-name name ;
     } cleave ;
 
 : CREATE-C-TYPE ( -- word )
-    scan (CREATE-C-TYPE) ;
+    scan-token (CREATE-C-TYPE) ;
 
 <PRIVATE
 GENERIC: return-type-name ( type -- name )
@@ -84,24 +81,25 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
     [ [ <pointer> ] dip parse-pointers ] when ;
 
 : next-enum-member ( members name value -- members value' )
-    [ 2array suffix! ] [ 1 + ] bi ;
+    [ define-enum-value ]
+    [ [ 2array suffix! ] [ enum>number 1 + ] bi ] 2bi ;
 
 : parse-enum-name ( -- name )
-    scan (CREATE-C-TYPE) dup save-location ;
+    CREATE-C-TYPE dup save-location ;
 
 : parse-enum-base-type ( -- base-type token )
-    scan dup "<" =
+    scan-token dup "<" =
-    [ drop scan-object scan ]
+    [ drop scan-object scan-token ]
     [ [ int ] dip ] if ;
 
 : parse-enum-member ( members name value -- members value' )
     over "{" =
-    [ 2drop scan create-in scan-object next-enum-member "}" expect ]
+    [ 2drop scan-token create-class-in scan-object next-enum-member "}" expect ]
-    [ [ create-in ] dip next-enum-member ] if ;
+    [ [ create-class-in ] dip next-enum-member ] if ;
 
 : parse-enum-members ( members counter token -- members )
     dup ";" = not
-    [ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ;
+    [ swap parse-enum-member scan-token parse-enum-members ] [ 2drop ] if ;
 
 PRIVATE>
 
@@ -111,14 +109,14 @@ PRIVATE>
     [ V{ } clone 0 ] dip parse-enum-members ;
 
 : scan-function-name ( -- return function )
-    scan-c-type scan parse-pointers ;
+    scan-c-type scan-token parse-pointers ;
 
 :: (scan-c-args) ( end-marker types names -- )
-    scan :> type-str
+    scan-token :> type-str
     type-str end-marker = [
         type-str { "(" ")" } member? [
             type-str parse-c-type :> type
-            scan "," ?tail drop :> name
+            scan-token "," ?tail drop :> name
             type name parse-pointers :> ( type' name' )
             type' types push name' names push
         ] unless
@@ -157,7 +155,7 @@ PRIVATE>
     void* type-word typedef
     type-word names return function-effect "callback-effect" set-word-prop
     type-word lib "callback-library" set-word-prop
-    type-word return types lib library-abi callback-quot (( quot -- alien )) ;
+    type-word return types lib library-abi callback-quot ( quot -- alien ) ;
 
 : (CALLBACK:) ( -- word quot effect )
     current-library get
@@ -173,11 +171,22 @@ PREDICATE: alien-function-word < alien-function-alias-word
     [ def>> third ] [ name>> ] bi = ;
 
 PREDICATE: alien-callback-type-word < typedef-word
-    "callback-effect" word-prop ;
+    "callback-effect" word-prop >boolean ;
 
 : global-quot ( type word -- quot )
     swap [ name>> current-library get ] dip
     '[ _ _ address-of 0 _ alien-value ] ;
 
+: set-global-quot ( type word -- quot )
+    swap [ name>> current-library get ] dip
+    '[ _ _ address-of 0 _ set-alien-value ] ;
+
+: define-global-getter ( type word -- )
+    [ nip ] [ global-quot ] 2bi ( -- value ) define-declared ;
+
+: define-global-setter ( type word -- )
+    [ nip name>> "set-" prepend create-in ]
+    [ set-global-quot ] 2bi ( obj -- ) define-declared ;
+
 : define-global ( type word -- )
-    [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
+    [ define-global-getter ] [ define-global-setter ] 2bi ;

basis/alien/prettyprint/prettyprint.factor

@@ -124,7 +124,7 @@ M: enum-c-type-word synopsis*
         [ seeing-word ]
         [ definer. ]
         [ pprint-word ]
-        [ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
+        [ lookup-c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
     } cleave ;
 M: enum-c-type-word definition
-    c-type members>> ;
+   lookup-c-type members>> ;

basis/alien/remote-control/remote-control-tests.factor

@@ -11,7 +11,7 @@ IN: alien.remote-control.tests
     try-process ;
 
 : run-test ( -- line )
-    os windows? "temp/a.exe" "temp/a.out" ?
+    os windows? "a.exe" "a.out" ?
     ascii [ readln ] with-process-reader ;
 
 :: test-embedding ( code -- line )
@@ -36,8 +36,8 @@ int main(int argc, char **argv)
 }
         ]I
     ] with-string-writer
-    "resource:temp" [ compile-file ] with-directory
+    [ compile-file ] with-temp-directory
-    "resource:" [ run-test ] with-directory ;
+    [ run-test ] with-temp-directory ;
 
 ! [ "Done." ] [ "" test-embedding ] unit-test
 

basis/alien/remote-control/remote-control.factor

@@ -19,8 +19,8 @@ IN: alien.remote-control
     dup optimized? [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
-    \ eval-callback ?callback 16 set-special-object
+    \ eval-callback ?callback OBJ-EVAL-CALLBACK set-special-object
-    \ yield-callback ?callback 17 set-special-object
+    \ yield-callback ?callback OBJ-YIELD-CALLBACK set-special-object
-    \ sleep-callback ?callback 18 set-special-object ;
+    \ sleep-callback ?callback OBJ-SLEEP-CALLBACK set-special-object ;
 
 MAIN: init-remote-control

basis/alien/syntax/syntax-docs.factor

@@ -83,7 +83,7 @@ HELP: ENUM:
 HELP: C-TYPE:
 { $syntax "C-TYPE: type" }
 { $values { "type" "a new C type" } }
-{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a " { $link pointer } "."
+{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a " { $link pointer } "." $nl
 { $snippet "C-TYPE:" } " can also be used to forward declare C types, allowing circular dependencies to occur between types. For example:"
 { $code """C-TYPE: forward 
 STRUCT: backward { x forward* } ;
@@ -122,4 +122,14 @@ HELP: typedef
 HELP: C-GLOBAL:
 { $syntax "C-GLOBAL: type name" }
 { $values { "type" "a C type" } { "name" "a C global variable name" } }
-{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
+{ $description "Defines a getter " { $snippet "name" } " and setter " { $snippet "set-name" } " for the global value in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
+
+ARTICLE: "alien.enums" "Enumeration types"
+"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum singletons and integers. It is possible to dispatch off of members of an enum."
+$nl
+"Defining enums:"
+{ $subsection POSTPONE: ENUM: }
+"Defining enums at run-time:"
+{ $subsection define-enum }
+"Conversions between enums and integers:"
+{ $subsections enum>number number>enum } ;

basis/alien/syntax/syntax.factor

@@ -13,7 +13,7 @@ SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
 
 SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
 
-SYNTAX: LIBRARY: scan current-library set ;
+SYNTAX: LIBRARY: scan-token current-library set ;
 
 SYNTAX: FUNCTION:
     (FUNCTION:) make-function define-inline ;
@@ -29,15 +29,15 @@ SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
 SYNTAX: ENUM:
-    parse-enum define-enum ;
+    parse-enum (define-enum) ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;
 
 SYNTAX: &:
-    scan current-library get '[ _ _ address-of ] append! ;
+    scan-token current-library get '[ _ _ address-of ] append! ;
 
-SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
+SYNTAX: C-GLOBAL: scan-c-type scan-new-word define-global ;
 
 SYNTAX: pointer:
     scan-c-type <pointer> suffix! ;

basis/ascii/ascii.factor

@@ -10,13 +10,13 @@ IN: ascii
 : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
 : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
 : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
-: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
+: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline
 : quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
 : Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
 : alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
-: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline
+: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline
 : >lower ( str -- lower ) [ ch>lower ] map ;
-: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline
+: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline
 : >upper ( str -- upper ) [ ch>upper ] map ;
 
 HINTS: >lower string ;

basis/atk/atk.factor

@@ -0,0 +1,5 @@
+! Copyright (C) 2009 Anton Gorenko.
+! See http://factorcode.org/license.txt for BSD license.
+USING: atk.ffi ;
+IN: atk
+

basis/atk/authors.txt

@@ -0,0 +1 @@
+Anton Gorenko

basis/atk/ffi/ffi.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2010 Anton Gorenko.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.libraries alien.syntax combinators
+gobject-introspection kernel system vocabs ;
+IN: atk.ffi
+
+<<
+"gobject.ffi" require
+>>
+
+LIBRARY: atk
+
+<<
+"atk" {
+    { [ os windows? ] [ "libatk-1.0-0.dll" cdecl add-library ] }
+    { [ os unix? ] [ drop ] }
+} cond
+>>
+
+GIR: vocab:atk/Atk-1.0.gir

basis/atk/summary.txt

@@ -0,0 +1 @@
+Atk binding

basis/base64/base64-docs.factor

@@ -7,12 +7,12 @@ HELP: >base64
 { $examples
     { $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
 }
-{ $see-also base64> >base64-lines } ;
+{ $see-also >base64-lines base64> } ;
 
 HELP: >base64-lines
 { $values { "seq" sequence } { "base64" "a string of base64 characters" } }
 { $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." }
-{ $see-also base64> >base64-lines } ;
+{ $see-also >base64 base64> } ;
 
 
 HELP: base64>

basis/base64/base64.factor

@@ -44,7 +44,7 @@ SYMBOL: column
 
 : encode3 ( seq -- )
     be> 4 iota <reversed> [
-        -6 * shift HEX: 3f bitand ch>base64 write1-lines
+        -6 * shift 0x3f bitand ch>base64 write1-lines
     ] with each ; inline
 
 : encode-pad ( seq n -- )

basis/biassocs/biassocs-docs.factor

@@ -18,10 +18,10 @@ HELP: once-at
 
 HELP: >biassoc
 { $values { "assoc" assoc } { "biassoc" biassoc } }
-{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
+{ $description "Constructs a new biassoc with the same key/value pairs as the given assoc." } ;
 
 ARTICLE: "biassocs" "Bidirectional assocs"
-"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
+"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc operations (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
 $nl
 "Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
 $nl

basis/binary-search/binary-search.factor

@@ -14,9 +14,9 @@ IN: binary-search
         midpoint@ midpoint
     ] [
         midpoint quot call {
-            { +eq+ [ midpoint@ midpoint ] }
             { +lt+ [ seq from midpoint@ quot (search) ] }
             { +gt+ [ seq midpoint@ to quot (search) ] }
+            { +eq+ [ midpoint@ midpoint ] }
         } case
     ] if ; inline recursive
 

basis/bit-arrays/bit-arrays-docs.factor

@@ -43,7 +43,7 @@ HELP: ?{
 HELP: bit-array
 { $description "The class of fixed-length bit arrays." } ;
 
-HELP: <bit-array> ( n -- bit-array )
+HELP: <bit-array>
 { $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link bit-array } } }
 { $description "Creates a new bit array with the given length and all elements initially set to " { $link f } "." } ;
 

basis/bit-arrays/bit-arrays-tests.factor

@@ -2,6 +2,8 @@ USING: alien sequences sequences.private arrays bit-arrays kernel
 tools.test math random ;
 IN: bit-arrays.tests
 
+[ -1 <bit-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
+
 [ 100 ] [ 100 <bit-array> length ] unit-test
 
 [
@@ -65,12 +67,12 @@ IN: bit-arrays.tests
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
 } ] [
-    HEX: ffffffffffffffffffffffffffffffff integer>bit-array
+    0xffffffffffffffffffffffffffffffff integer>bit-array
 ] unit-test
 
 [ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
 [ 0 ] [ ?{ } bit-array>integer ] unit-test
-[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
+[ 0xffffffffffffffffffffffffffffffff ] [ ?{
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
@@ -81,6 +83,6 @@ IN: bit-arrays.tests
 
 [ 1 ] [ ?{ f t f t } byte-length ] unit-test
 
-[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test
+[ 0xa ] [ ?{ f t f t } bit-array>integer ] unit-test
 
-[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test
+[ 0x100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2007, 2010 Slava Pestov.
+! Copyright (C) 2007, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.data accessors io.binary math math.bitwise
 alien.accessors kernel kernel.private sequences
 sequences.private byte-arrays parser prettyprint.custom fry
 locals ;
+FROM: sequences.private => change-nth-unsafe ;
 IN: bit-arrays
 
 TUPLE: bit-array
@@ -41,8 +42,12 @@ TUPLE: bit-array
 
 PRIVATE>
 
+ERROR: bad-array-length n ;
+
 : <bit-array> ( n -- bit-array )
-    dup bits>bytes <byte-array> bit-array boa ; inline
+    dup 0 < [ bad-array-length ] when
+    dup bits>bytes <byte-array>
+    bit-array boa ; inline
 
 M: bit-array length length>> ; inline
 

basis/bit-sets/bit-sets-tests.factor

@@ -64,3 +64,8 @@ IN: bit-sets.tests
 
 [ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
 [ 1 <bit-set> dup clone 0 over adjoin ] unit-test
+
+[ 0 ] [ T{ bit-set f ?{ } } cardinality ] unit-test
+[ 0 ] [ T{ bit-set f ?{ f f f f } } cardinality ] unit-test
+[ 1 ] [ T{ bit-set f ?{ f t f f } } cardinality ] unit-test
+[ 2 ] [ T{ bit-set f ?{ f t f t } } cardinality ] unit-test

basis/bit-sets/bit-sets.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
+USING: kernel accessors sequences byte-arrays bit-arrays math
+math.bitwise hints sets ;
 IN: bit-sets
 
 TUPLE: bit-set { table bit-array read-only } ;
@@ -14,19 +15,21 @@ M: bit-set in?
     over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
 
 M: bit-set adjoin
-    ! This is allowed to crash when the elt couldn't go in the set
+    ! This is allowed to throw an error when the elt couldn't
+    ! go in the set
     [ t ] 2dip table>> set-nth ;
 
 M: bit-set delete
-    ! This isn't allowed to crash if the elt wasn't in the set
+    ! This isn't allowed to throw an error if the elt wasn't
+    ! in the set
     over integer? [
         table>> 2dup bounds-check? [
             [ f ] 2dip set-nth
         ] [ 2drop ] if
     ] [ 2drop ] if ;
 
-! If you do binary set operations with a bitset, it's expected
+! If you do binary set operations with a bit-set, it's expected
-! that the other thing can also be represented as a bitset
+! that the other thing can also be represented as a bit-set
 ! of the same length.
 <PRIVATE
 
@@ -70,8 +73,9 @@ M: bit-set members
 <PRIVATE
 
 : bit-set-like ( set bit-set -- bit-set' )
-    ! This crashes if there are keys that can't be put in the bit set
+    ! Throws an error if there are keys that can't be put
-    over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
+    ! in the bit set
+    over bit-set? [ 2dup [ table>> length ] same? ] [ f ] if
     [ drop ] [
         [ members ] dip table>> length <bit-set>
         [ [ adjoin ] curry each ] keep
@@ -84,3 +88,6 @@ M: bit-set set-like
 
 M: bit-set clone
     table>> clone bit-set boa ;
+
+M: bit-set cardinality
+    table>> bit-count ;

basis/bitstreams/bitstreams-tests.factor

@@ -5,44 +5,44 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-[ BIN: 1111111111 ]
+[ 0b1111111111 ]
 [
-    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    B{ 0x0f 0xff 0xff 0xff } <msb0-bit-reader>
     2 >>byte-pos 6 >>bit-pos
     10 swap peek
 ] unit-test
 
-[ BIN: 111111111 ]
+[ 0b111111111 ]
 [
-    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    B{ 0x0f 0xff 0xff 0xff } <msb0-bit-reader>
     2 >>byte-pos 6 >>bit-pos
     9 swap peek
 ] unit-test
 
-[ BIN: 11111111 ]
+[ 0b11111111 ]
 [
-    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    B{ 0x0f 0xff 0xff 0xff } <msb0-bit-reader>
     2 >>byte-pos 6 >>bit-pos
     8 swap peek
 ] unit-test
 
-[ BIN: 1111111 ]
+[ 0b1111111 ]
 [
-    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    B{ 0x0f 0xff 0xff 0xff } <msb0-bit-reader>
     2 >>byte-pos 6 >>bit-pos
     7 swap peek
 ] unit-test
 
-[ BIN: 111111 ]
+[ 0b111111 ]
 [
-    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    B{ 0x0f 0xff 0xff 0xff } <msb0-bit-reader>
     2 >>byte-pos 6 >>bit-pos
     6 swap peek
 ] unit-test
 
-[ BIN: 11111 ]
+[ 0b11111 ]
 [
-    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    B{ 0x0f 0xff 0xff 0xff } <msb0-bit-reader>
     2 >>byte-pos 6 >>bit-pos
     5 swap peek
 ] unit-test

basis/bitstreams/bitstreams.factor

@@ -49,7 +49,7 @@ TUPLE: lsb0-bit-writer < bit-writer ;
 : new-bit-writer ( class -- bs )
     new
         BV{ } clone >>bytes
-        0 0 <widthed> >>widthed ; inline
+        zero-widthed >>widthed ; inline
 
 : <msb0-bit-writer> ( -- bs )
     msb0-bit-writer new-bit-writer ;
@@ -170,7 +170,7 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
     ] unless
     writer bytes>> ;
 
-:: byte-array-n>seq ( byte-array n -- seq )
+:: byte-array-n>sequence ( byte-array n -- seq )
     byte-array length 8 * n / iota
     byte-array <msb0-bit-reader> '[
         drop n _ read

basis/bootstrap/bootstrap-error.factor

@@ -3,7 +3,7 @@ USING: continuations kernel io debugger vocabs words system namespaces ;
 :c
 :error
 
-"listener" vocab
+"listener" lookup-vocab
 [ restarts. vocab-main execute ]
 [ error get die ] if*
 1 exit

basis/bootstrap/compiler/compiler.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors cpu.architecture vocabs.loader system
+USING: accessors cpu.architecture vocabs system
 sequences namespaces parser kernel kernel.private classes
 classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
-growable namespaces.private assocs words command-line vocabs io
+growable namespaces.private assocs words command-line io
 io.encodings.string libc splitting math.parser memory compiler.units
-math.order quotations quotations.private assocs.private ;
+math.order quotations quotations.private assocs.private vocabs.loader ;
 FROM: compiler => enable-optimizer ;
 IN: bootstrap.compiler
 
@@ -42,7 +42,7 @@ gc
     ! Compile a set of words ahead of the full compile.
     ! This set of words was determined semi-empirically
     ! using the profiler. It improves bootstrap time
-    ! significantly, because frequenly called words
+    ! significantly, because frequently called words
     ! which are also quick to compile are replaced by
     ! compiled definitions as soon as possible.
     {
@@ -94,7 +94,7 @@ gc
 
     {
         member-eq? split harvest sift cut cut-slice start index clone
-        set-at reverse push-all class number>string string>number
+        set-at reverse push-all class-of number>string string>number
         like clone-like
     } compile-unoptimized
 
@@ -107,6 +107,17 @@ gc
 
     "." write flush
 
+    os windows? [
+        "GetLastError" "windows.kernel32" lookup-word
+        "FormatMessageW" "windows.kernel32" lookup-word
+        2array compile-unoptimized
+    ] when
+
+    os unix? [
+        "(dlerror)" "alien.libraries.unix" lookup-word
+        1array compile-unoptimized
+    ] when
+
     {
         malloc calloc free memcpy
     } compile-unoptimized
@@ -118,7 +129,6 @@ gc
     " done" print flush
 
     "alien.syntax" require
-    "alien.complex" require
     "io.streams.byte-array.fast" require
 
 ] unless

basis/bootstrap/finish-bootstrap.factor

@@ -1,22 +1,12 @@
-USING: init command-line debugger system continuations
+USING: init io command-line.startup debugger system
-namespaces eval kernel vocabs.loader io ;
+continuations parser.notes namespaces ;
 
 [
+    ! Set parser-quiet? to match parser.notes top-level form
+    t parser-quiet? set-global
+    
     boot
-    do-startup-hooks
+    [ do-startup-hooks command-line-startup ]
-    [
+    [ print-error :c flush 1 exit ]
-        (command-line) parse-command-line
+    recover
-        load-vocab-roots
-        run-user-init
-
-        "e" get script get or [
-            "e" get [ eval( -- ) ] when*
-            script get [ run-script ] when*
-        ] [
-            "run" get run
-        ] if
-
-        output-stream get [ stream-flush ] when*
-        0 exit
-    ] [ print-error 1 exit ] recover
 ] set-startup-quot

basis/bootstrap/help/help.factor

@@ -1,6 +1,6 @@
 USING: help help.topics help.syntax help.crossref
-help.definitions io io.files kernel namespaces vocabs sequences
+help.definitions io io.files kernel namespaces sequences
-parser vocabs.loader vocabs.loader.private accessors assocs ;
+parser vocabs vocabs.loader vocabs.loader.private accessors assocs ;
 IN: bootstrap.help
 
 : load-help ( -- )
@@ -9,7 +9,7 @@ IN: bootstrap.help
 
     t load-help? set-global
 
-    [ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [
+    [ dup lookup-vocab [ drop ] [ no-vocab ] if ] require-hook [
         dictionary get values
         [ docs-loaded?>> not ] filter
         [ load-docs ] each

basis/bootstrap/image/download/download.factor

@@ -4,7 +4,7 @@ USING: http.client checksums checksums.md5 splitting assocs
 kernel io.files bootstrap.image sequences io urls ;
 IN: bootstrap.image.download
 
-CONSTANT: url URL" http://factorcode.org/images/latest/"
+CONSTANT: url URL" http://downloads.factorcode.org/images/latest/"
 
 : download-checksums ( -- alist )
     url "checksums.txt" >url derive-url http-get nip

basis/bootstrap/image/image-docs.factor

@@ -16,5 +16,5 @@ ABOUT: "bootstrap.image"
 HELP: make-image
 { $values { "arch" string } }
 { $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
-{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" }
+{ $code "x86.32" "unix-x86.64" "windows-x86.64" "linux-ppc" }
 "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

basis/bootstrap/image/image.factor

@@ -1,24 +1,27 @@
-! Copyright (C) 2004, 2010 Slava Pestov.
+! Copyright (C) 2004, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings arrays byte-arrays generic hashtables
 hashtables.private io io.binary io.files io.encodings.binary
 io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.generalizations strings sbufs
+prettyprint sequences combinators.smart strings sbufs vectors
-vectors words quotations assocs system layouts splitting
+words quotations assocs system layouts splitting grouping
-grouping growable classes classes.private classes.builtin
+growable classes classes.private classes.builtin classes.tuple
-classes.tuple classes.tuple.private vocabs vocabs.loader
+classes.tuple.private vocabs vocabs.loader source-files
-source-files definitions debugger quotations.private combinators
+definitions debugger quotations.private combinators
 combinators.short-circuit math.order math.private accessors
 slots.private generic.single.private compiler.units
-compiler.constants fry locals bootstrap.image.syntax
+compiler.constants compiler.codegen.relocation fry locals
-generalizations ;
+bootstrap.image.syntax parser.notes namespaces.private ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
-    [ "winnt" = "winnt" "unix" ? ] dip "-" glue ;
+    2dup [ windows? ] [ ppc? ] bi* or [
+      [ drop unix ] dip
+    ] unless
+    [ name>> ] [ name>> ] bi* "-" glue ;
 
 : my-arch ( -- arch )
-    os name>> cpu name>> arch ;
+    os cpu arch ;
 
 : boot-image-name ( arch -- string )
     "boot." ".image" surround ;
@@ -28,8 +31,8 @@ IN: bootstrap.image
 
 : images ( -- seq )
     {
-        "winnt-x86.32" "unix-x86.32"
+        "windows-x86.32" "unix-x86.32"
-        "winnt-x86.64" "unix-x86.64"
+        "windows-x86.64" "unix-x86.64"
     } ;
 
 <PRIVATE
@@ -45,7 +48,7 @@ M: eql-wrapper hashcode* obj>> hashcode* ;
 GENERIC: (eql?) ( obj1 obj2 -- ? )
 
 : eql? ( obj1 obj2 -- ? )
-    { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
+    { [ [ class-of ] same? ] [ (eql?) ] } 2&& ;
 
 M: fixnum (eql?) eq? ;
 
@@ -53,7 +56,7 @@ M: bignum (eql?) = ;
 
 M: float (eql?) fp-bitwise= ;
 
-M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
+M: sequence (eql?) 2dup [ length ] same? [ [ eql? ] 2all? ] [ 2drop f ] if ;
 
 M: object (eql?) = ;
 
@@ -84,12 +87,12 @@ SYMBOL: objects
 
 ! Constants
 
-CONSTANT: image-magic HEX: 0f0e0d0c
+CONSTANT: image-magic 0x0f0e0d0c
 CONSTANT: image-version 4
 
 CONSTANT: data-base 1024
 
-CONSTANT: special-objects-size 70
+CONSTANT: special-objects-size 80
 
 CONSTANT: header-size 10
 
@@ -101,62 +104,40 @@ CONSTANT: -1-offset             9
 
 SYMBOL: sub-primitives
 
-SYMBOL: jit-relocations
-
-SYMBOL: jit-offset
-
-: compute-offset ( -- offset )
-    building get length jit-offset get + ;
-
-: jit-rel ( rc rt -- )
-    compute-offset 3array jit-relocations get push-all ;
-
-SYMBOL: jit-parameters
-
-: jit-parameter ( parameter -- )
-    jit-parameters get push ;
-
-SYMBOL: jit-literals
-
-: jit-literal ( literal -- )
-    jit-literals get push ;
-
-: jit-vm ( offset rc -- )
-    [ jit-parameter ] dip rt-vm jit-rel ;
-
-: jit-dlsym ( name rc -- )
-    rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
-
 :: jit-conditional ( test-quot false-quot -- )
     [ 0 test-quot call ] B{ } make length :> len
-    building get length jit-offset get + len +
+    building get length extra-offset get + len +
-    [ jit-offset set false-quot call ] B{ } make
+    [ extra-offset set false-quot call ] B{ } make
     [ length test-quot call ] [ % ] bi ; inline
 
-: make-jit ( quot -- jit-parameters jit-literals jit-code )
+: make-jit ( quot -- parameters literals code )
+    #! code is a { relocation insns } pair
     [
-        0 jit-offset set
+        0 extra-offset set
-        V{ } clone jit-parameters set
+        init-relocation
-        V{ } clone jit-literals set
-        V{ } clone jit-relocations set
         call( -- )
-        jit-parameters get >array
+        parameter-table get >array
-        jit-literals get >array
+        literal-table get >array
-        jit-relocations get >array
+        relocation-table get >byte-array
-    ] B{ } make prefix ;
+    ] B{ } make 2array ;
+
+: make-jit-no-params ( quot -- code )
+    make-jit 2nip ;
 
 : jit-define ( quot name -- )
-    [ make-jit 2nip ] dip set ;
+    [ make-jit-no-params ] dip set ;
 
 : define-sub-primitive ( quot word -- )
     [ make-jit 3array ] dip sub-primitives get set-at ;
 
 : define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
+    [
         [
             [ make-jit ]
-        [ make-jit 2nip ]
+            [ make-jit-no-params ]
-        [ make-jit 2nip ]
+            [ make-jit-no-params ]
-        tri* 5 narray
+            tri*
+        ] output>array
     ] dip
     sub-primitives get set-at ;
 
@@ -185,44 +166,49 @@ SPECIAL-OBJECT: jit-word-jump 26
 SPECIAL-OBJECT: jit-word-call 27
 SPECIAL-OBJECT: jit-if-word 28
 SPECIAL-OBJECT: jit-if 29
-SPECIAL-OBJECT: jit-epilog 30
+SPECIAL-OBJECT: jit-safepoint 30
-SPECIAL-OBJECT: jit-return 31
+SPECIAL-OBJECT: jit-epilog 31
-SPECIAL-OBJECT: jit-profiling 32
+SPECIAL-OBJECT: jit-return 32
-SPECIAL-OBJECT: jit-push 33
+SPECIAL-OBJECT: jit-profiling 33
-SPECIAL-OBJECT: jit-dip-word 34
+SPECIAL-OBJECT: jit-push 34
-SPECIAL-OBJECT: jit-dip 35
+SPECIAL-OBJECT: jit-dip-word 35
-SPECIAL-OBJECT: jit-2dip-word 36
+SPECIAL-OBJECT: jit-dip 36
-SPECIAL-OBJECT: jit-2dip 37
+SPECIAL-OBJECT: jit-2dip-word 37
-SPECIAL-OBJECT: jit-3dip-word 38
+SPECIAL-OBJECT: jit-2dip 38
-SPECIAL-OBJECT: jit-3dip 39
+SPECIAL-OBJECT: jit-3dip-word 39
-SPECIAL-OBJECT: jit-execute 40
+SPECIAL-OBJECT: jit-3dip 40
-SPECIAL-OBJECT: jit-declare-word 41
+SPECIAL-OBJECT: jit-execute 41
+SPECIAL-OBJECT: jit-declare-word 42
 
-SPECIAL-OBJECT: c-to-factor-word 42
+SPECIAL-OBJECT: c-to-factor-word 43
-SPECIAL-OBJECT: lazy-jit-compile-word 43
+SPECIAL-OBJECT: lazy-jit-compile-word 44
-SPECIAL-OBJECT: unwind-native-frames-word 44
+SPECIAL-OBJECT: unwind-native-frames-word 45
-SPECIAL-OBJECT: fpu-state-word 45
+SPECIAL-OBJECT: fpu-state-word 46
-SPECIAL-OBJECT: set-fpu-state-word 46
+SPECIAL-OBJECT: set-fpu-state-word 47
+SPECIAL-OBJECT: signal-handler-word 48
+SPECIAL-OBJECT: leaf-signal-handler-word 49
+SPECIAL-OBJECT: ffi-signal-handler-word 50
+SPECIAL-OBJECT: ffi-leaf-signal-handler-word 51
 
-SPECIAL-OBJECT: callback-stub 48
+SPECIAL-OBJECT: callback-stub 53
 
 ! PIC stubs
-SPECIAL-OBJECT: pic-load 49
+SPECIAL-OBJECT: pic-load 54
-SPECIAL-OBJECT: pic-tag 50
+SPECIAL-OBJECT: pic-tag 55
-SPECIAL-OBJECT: pic-tuple 51
+SPECIAL-OBJECT: pic-tuple 56
-SPECIAL-OBJECT: pic-check-tag 52
+SPECIAL-OBJECT: pic-check-tag 57
-SPECIAL-OBJECT: pic-check-tuple 53
+SPECIAL-OBJECT: pic-check-tuple 58
-SPECIAL-OBJECT: pic-hit 54
+SPECIAL-OBJECT: pic-hit 59
-SPECIAL-OBJECT: pic-miss-word 55
+SPECIAL-OBJECT: pic-miss-word 60
-SPECIAL-OBJECT: pic-miss-tail-word 56
+SPECIAL-OBJECT: pic-miss-tail-word 61
 
 ! Megamorphic dispatch
-SPECIAL-OBJECT: mega-lookup 57
+SPECIAL-OBJECT: mega-lookup 62
-SPECIAL-OBJECT: mega-lookup-word 58
+SPECIAL-OBJECT: mega-lookup-word 63
-SPECIAL-OBJECT: mega-miss-word 59
+SPECIAL-OBJECT: mega-miss-word 64
 
 ! Default definition for undefined words
-SPECIAL-OBJECT: undefined-quot 60
+SPECIAL-OBJECT: undefined-quot 65
 
 : special-object-offset ( symbol -- n )
     special-objects get at header-size + ;
@@ -291,14 +277,14 @@ GENERIC: ' ( obj -- ptr )
 
 : bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 
-: bignum>seq ( n -- seq )
+: bignum>sequence ( n -- seq )
     #! n is positive or zero.
     [ dup 0 > ]
     [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
     produce nip ;
 
 : emit-bignum ( n -- )
-    dup dup 0 < [ neg ] when bignum>seq
+    dup dup 0 < [ neg ] when bignum>sequence
     [ nip length 1 + emit-fixnum ]
     [ drop 0 < 1 0 ? emit ]
     [ nip emit-seq ]
@@ -349,7 +335,7 @@ M: f ' drop \ f type-number ;
 ! Words
 
 : word-sub-primitive ( word -- obj )
-    global [ target-word ] bind sub-primitives get at ;
+    [ target-word ] with-global sub-primitives get at ;
 
 : emit-word ( word -- )
     [
@@ -364,11 +350,8 @@ M: f ' drop \ f type-number ;
                     [ props>> , ]
                     [ pic-def>> , ]
                     [ pic-tail-def>> , ]
-                    [ drop 0 , ] ! count
                     [ word-sub-primitive , ]
-                    [ drop 0 , ] ! xt
+                    [ drop 0 , ] ! entry point
-                    [ drop 0 , ] ! code
-                    [ drop 0 , ] ! profiling
                 } cleave
             ] { } make [ ' ] map
         ] bi
@@ -459,11 +442,11 @@ ERROR: tuple-removed class ;
 
 : (emit-tuple) ( tuple -- pointer )
     [ tuple-slots ]
-    [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
+    [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
     tuple [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
-    dup class name>> "tombstone" =
+    dup class-of name>> "tombstone" =
     [ [ (emit-tuple) ] cache-eql-object ]
     [ [ (emit-tuple) ] cache-eq-object ]
     if ;
@@ -472,7 +455,7 @@ M: tuple ' emit-tuple ;
 
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
-    "hashtables.private" lookup def>> first
+    "hashtables.private" lookup-word def>> first
     [ emit-tuple ] cache-eql-object ;
 
 ! Arrays
@@ -507,8 +490,7 @@ M: quotation '
             emit ! array
             f ' emit ! cached-effect
             f ' emit ! cache-counter
-            0 emit ! xt
+            0 emit ! entry point
-            0 emit ! code
         ] emit-object
     ] cache-eql-object ;
 
@@ -521,11 +503,12 @@ M: quotation '
     {
         dictionary source-files builtins
         update-map implementors-map
-    } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
+    } [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc
     {
         class<=-cache class-not-cache classes-intersect-cache
         class-and-cache class-or-cache next-method-quot-cache
-    } [ H{ } clone ] H{ } map>assoc assoc-union
+    } [ H{ } clone global-box boa ] H{ } map>assoc assoc-union
+    global-hashtable boa
     bootstrap-global set ;
 
 : emit-jit-data ( -- )
@@ -544,6 +527,10 @@ M: quotation '
     \ unwind-native-frames unwind-native-frames-word set
     \ fpu-state fpu-state-word set
     \ set-fpu-state set-fpu-state-word set
+    \ signal-handler signal-handler-word set
+    \ leaf-signal-handler leaf-signal-handler-word set
+    \ ffi-signal-handler ffi-signal-handler-word set
+    \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set
     undefined-def undefined-quot set ;
 
 : emit-special-objects ( -- )
@@ -598,12 +585,14 @@ M: quotation '
 PRIVATE>
 
 : make-image ( arch -- )
-    [
+    architecture associate H{
-        architecture set
+        { parser-quiet? f }
+        { auto-use? f }
+    } assoc-union! [
         "resource:/core/bootstrap/stage1.factor" run-file
         build-image
         write-image
-    ] with-scope ;
+    ] with-variables ;
 
 : make-images ( -- )
     images [ make-image ] each ;

basis/bootstrap/image/syntax/syntax.factor

@@ -8,7 +8,7 @@ SYMBOL: special-objects
 SYNTAX: RESET H{ } clone special-objects set-global ;
 
 SYNTAX: SPECIAL-OBJECT:
-    CREATE-WORD scan-word
+    scan-new-word scan-number
     [ swap special-objects get set-at ]
     [ drop define-symbol ]
     2bi ;

basis/bootstrap/image/upload/upload.factor

@@ -10,7 +10,7 @@ SYMBOL: upload-images-destination
 
 : destination ( -- dest )
     upload-images-destination get
-    "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+    "slava_pestov@downloads.factorcode.org:downloads.factorcode.org/images/latest/"
     or ;
 
 : checksums ( -- temp ) "checksums.txt" temp-file ;
@@ -30,7 +30,7 @@ SYMBOL: upload-images-destination
     [
         "scp" ,
         boot-image-names %
-        "temp/checksums.txt" , destination ,
+        checksums , destination ,
     ] { } make try-process ;
 
 : new-images ( -- )

basis/bootstrap/io/io.factor

@@ -2,10 +2,11 @@ USING: system vocabs vocabs.loader kernel combinators
 namespaces sequences io.backend accessors ;
 IN: bootstrap.io
 
-"bootstrap.compiler" vocab [
+"bootstrap.compiler" require
+"bootstrap.threads" require
+
 "io.backend." {
     { [ "io-backend" get ] [ "io-backend" get ] }
     { [ os unix? ] [ "unix." os name>> append ] }
-        { [ os winnt? ] [ "windows.nt" ] }
+    { [ os windows? ] [ "windows" ] }
 } cond append require
-] when

basis/bootstrap/stage2.factor

@@ -1,11 +1,9 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors init namespaces words words.symbol io
+USING: command-line compiler.units continuations definitions io
-kernel.private math memory continuations kernel io.files
+io.pathnames kernel math math.parser memory namespaces parser
-io.pathnames io.backend system parser vocabs sequences
+parser.notes sequences sets splitting system
-vocabs.loader combinators splitting source-files strings
+vocabs vocabs.loader ;
-definitions assocs compiler.units math.parser
-generic sets command-line ;
 IN: bootstrap.stage2
 
 SYMBOL: core-bootstrap-time
@@ -62,6 +60,10 @@ SYMBOL: bootstrap-time
     ! We time bootstrap
     nano-count
 
+    ! parser.notes sets this to t in the global namespace.
+    ! We have to change it back in finish-bootstrap.factor
+    f parser-quiet? set-global
+
     default-image-name "output-image" set-global
 
     "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
@@ -72,8 +74,7 @@ SYMBOL: bootstrap-time
     (command-line) parse-command-line
 
     ! Set dll paths
-    os wince? [ "windows.ce" require ] when
+    os windows? [ "windows" require ] when
-    os winnt? [ "windows.nt" require ] when
 
     "staging" get "deploy-vocab" get or [
         "stage2: deployment mode" print

basis/bootstrap/threads/threads.factor

@@ -1,9 +1,6 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs.loader kernel io.thread threads
+USE: vocabs
-compiler.utilities namespaces ;
-IN: bootstrap.threads
 
-{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
+"threads" require
-
+"io.thread" require
-[ yield ] yield-hook set-global

basis/bootstrap/tools/tools.factor

@@ -1,4 +1,4 @@
-USING: vocabs.loader sequences system combinators ;
+USING: vocabs sequences system combinators ;
 IN: bootstrap.tools
 
 {
@@ -14,7 +14,7 @@ IN: bootstrap.tools
     "tools.disassembler"
     "tools.dispatch"
     "tools.memory"
-    "tools.profiler"
+    "tools.profiler.sampling"
     "tools.test"
     "tools.time"
     "tools.threads"

basis/bootstrap/ui/tools/tools.factor

@@ -1,7 +1,7 @@
-USING: kernel vocabs vocabs.loader sequences system ;
+USING: kernel vocabs sequences system vocabs.loader ;
 
 { "ui" "help" "tools" }
-[ "bootstrap." prepend vocab ] all? [
+[ "bootstrap." prepend lookup-vocab ] all? [
     "ui.tools" require
 
     { "ui.backend.cocoa" } "ui.backend.cocoa.tools" require-when

basis/bootstrap/ui/ui.factor

@@ -1,13 +1,15 @@
 USING: alien namespaces system combinators kernel sequences
-vocabs vocabs.loader ;
+vocabs ;
 IN: bootstrap.ui
 
-"bootstrap.compiler" vocab [
+"bootstrap.math" require
+"bootstrap.compiler" require
+"bootstrap.threads" require
+
 "ui-backend" get [
     {
         { [ os macosx? ] [ "cocoa" ] }
         { [ os windows? ] [ "windows" ] }
-            { [ os unix? ] [ "x11" ] }
+        { [ os unix? ] [ "gtk" ] }
     } cond
 ] unless* "ui.backend." prepend require
-] when

basis/byte-arrays/hex/hex-docs.factor

@@ -5,4 +5,4 @@ USING: byte-arrays help.markup help.syntax ;
 
 HELP: HEX{
 { $syntax "HEX{ 0123 45 67 89abcdef }" }
-{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ;
+{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored. There must be an even number of hex digits or an error is thrown." } ;

basis/byte-arrays/hex/hex-tests.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test byte-arrays.hex eval ;
+IN: byte-arrays.hex.tests
+
+[ B{ 16 0 8 0 } ] [ HEX{ 10 00 08 00 } ] unit-test
+[ B{ 255 255 15 255 255 255 } ] [ HEX{ ffff 0fff ffff } ] unit-test
+
+[ "HEX{ ffff fff ffff }" parse-string ] must-fail
+[ "HEX{ 10 00 08 0 }" parse-string ] must-fail
+[ "HEX{ 1 00 00 80 }" parse-string ] must-fail

basis/byte-arrays/hex/hex.factor

@@ -1,10 +1,14 @@
-! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
+! Copyright (C) 2009,2011 Maxim Savchenko, Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: grouping lexer ascii parser sequences kernel math.parser ;
+USING: ascii grouping kernel math.parser sequences
+strings.parser lexer math ;
 IN: byte-arrays.hex
 
+ERROR: odd-length-hex-string string ;
+
 SYNTAX: HEX{
     "}" parse-tokens "" join
     [ blank? not ] filter
+    dup length even? [ odd-length-hex-string ] unless
     2 group [ hex> ] B{ } map-as
     suffix! ;

basis/cache/cache-tests.factor

@@ -0,0 +1,50 @@
+USING: cache tools.test accessors destructors kernel assocs
+namespaces ;
+IN: cache.tests
+
+TUPLE: mock-disposable < disposable n ;
+
+: <mock-disposable> ( n -- mock-disposable )
+    mock-disposable new-disposable swap >>n ;
+
+M: mock-disposable dispose* drop ;
+
+[ ] [ <cache-assoc> "cache" set ] unit-test
+
+[ 0 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get 2 >>max-age drop ] unit-test
+
+[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test
+
+[ 1 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get purge-cache ] unit-test
+
+[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test
+
+[ 2 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get purge-cache ] unit-test
+
+[ 1 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test
+
+[ 2 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get purge-cache ] unit-test
+
+[ 1 ] [ "cache" get assoc-size ] unit-test
+
+[ f ] [ 2 "cache" get key? ] unit-test
+
+[ 3 ] [ 4 "cache" get at n>> ] unit-test
+
+[ t ] [ "a" get disposed>> ] unit-test
+
+[ f ] [ "b" get disposed>> ] unit-test
+
+[ ] [ "cache" get clear-assoc ] unit-test
+
+[ t ] [ "b" get disposed>> ] unit-test

basis/cache/cache.factor

@@ -25,19 +25,21 @@ M: cache-assoc set-at
     [ <cache-entry> ] 2dip
     assoc>> set-at ;
 
-M: cache-assoc clear-assoc assoc>> clear-assoc ;
+M: cache-assoc clear-assoc
+    [ assoc>> values dispose-each ]
+    [ assoc>> clear-assoc ]
+    bi ;
 
 M: cache-assoc >alist assoc>> [ value>> ] { } assoc-map-as ;
 
 INSTANCE: cache-assoc assoc
 
-M: cache-assoc dispose*
+M: cache-assoc dispose* clear-assoc ;
-    [ values dispose-each ] [ clear-assoc ] bi ;
 
 PRIVATE>
 
 : purge-cache ( cache -- )
     dup max-age>> '[
-        [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
+        [ nip [ 1 + ] change-age age>> _ < ] assoc-partition
-        [ values dispose-each ] dip
+        values dispose-each
     ] change-assoc drop ;

basis/cairo/cairo.factor

@@ -6,11 +6,11 @@ sequences namespaces fry continuations destructors math images
 images.memory math.rectangles ;
 IN: cairo
 
-ERROR: cairo-error message ;
+ERROR: cairo-error n message ;
 
 : (check-cairo) ( cairo_status_t -- )
     dup CAIRO_STATUS_SUCCESS =
-    [ drop ] [ cairo_status_to_string cairo-error ] if ;
+    [ drop ] [ [ ] [ cairo_status_to_string ] bi cairo-error ] if ;
 
 : check-cairo ( cairo -- ) cairo_status (check-cairo) ;
 

basis/cairo/ffi/ffi.factor

@@ -9,8 +9,8 @@ IN: cairo.ffi
 ! Adapted from cairo.h, version 1.8.10
 
 << {
-    { [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
+    { [ os windows? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
-    { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] }
+    { [ os macosx? ] [ "cairo" "libcairo.dylib" cdecl add-library ] }
     { [ os unix? ] [ ] }
 } cond >>
 
@@ -77,9 +77,9 @@ ENUM: cairo_status_t
     CAIRO_STATUS_INVALID_WEIGHT ;
 
 ENUM: cairo_content_t
-    { CAIRO_CONTENT_COLOR HEX: 1000 }
+    { CAIRO_CONTENT_COLOR 0x1000 }
-    { CAIRO_CONTENT_ALPHA HEX: 2000 }
+    { CAIRO_CONTENT_ALPHA 0x2000 }
-    { CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 } ;
+    { CAIRO_CONTENT_COLOR_ALPHA 0x3000 } ;
 
 CALLBACK: cairo_status_t
 cairo_write_func_t ( void* closure, uchar* data, uint length ) ;
@@ -385,7 +385,7 @@ FUNCTION: void
 cairo_text_cluster_free ( cairo_text_cluster_t* clusters ) ;
 
 ENUM: cairo_text_cluster_flags_t
-    { CAIRO_TEXT_CLUSTER_FLAG_BACKWARD HEX: 00000001 } ;
+    { CAIRO_TEXT_CLUSTER_FLAG_BACKWARD 0x00000001 } ;
 
 STRUCT: cairo_text_extents_t
     { x_bearing double }

basis/calendar/calendar-docs.factor

@@ -323,7 +323,7 @@ HELP: >local-time
 { $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
 { $examples
     { $example "USING: accessors calendar kernel prettyprint ;"
-               "now gmt >local-time [ gmt-offset>> ] bi@ = ."
+               "now gmt >local-time [ gmt-offset>> ] same? ."
                "t"
     }
 } ;
@@ -490,11 +490,15 @@ HELP: saturday
 
 HELP: midnight
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp that represents today at midnight, or the beginning of the day." } ;
+{ $description "Returns a new timestamp that represents the day at midnight, or the beginning of the day." } ;
 
 HELP: noon
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp that represents today at noon, or the middle of the day." } ;
+{ $description "Returns a new timestamp that represents the day at noon, or the middle of the day." } ;
+
+HELP: today
+{ $values { "timestamp" timestamp } }
+{ $description "Returns a timestamp that represents today at midnight." } ;
 
 HELP: beginning-of-month
 { $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
@@ -519,7 +523,7 @@ HELP: since-1970
 { $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
 
 ARTICLE: "calendar" "Calendar"
-"The two data types used throughout the calendar library:"
+"The " { $vocab-link "calendar" } " vocabulary defines two data types and a set of operations on them:"
 { $subsections
     timestamp
     duration
@@ -533,13 +537,12 @@ ARTICLE: "calendar" "Calendar"
     now
     gmt
 }
-"Converting between timestamps:"
+"Time zones:"
 { $subsections
     >local-time
     >gmt
+    convert-timezone
 }
-"Converting between timezones:"
-{ $subsections convert-timezone }
 "Timestamps relative to each other:"
 { $subsections "relative-timestamps" }
 "Operations on units of time:"
@@ -548,9 +551,10 @@ ARTICLE: "calendar" "Calendar"
     "months"
     "days"
 }
+"Both " { $link timestamp } "s and " { $link duration } "s implement the " { $link "math.order" } "."
+$nl
 "Meta-data about the calendar:"
-{ $subsections "calendar-facts" }
+{ $subsections "calendar-facts" } ;
-;
 
 ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic"
 "Adding timestamps and durations, or durations and durations:"

basis/calendar/calendar.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.tuple combinators
 combinators.short-circuit kernel locals math math.functions
-math.order sequences summary system threads vocabs.loader ;
+math.order sequences summary system vocabs vocabs.loader ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -33,19 +33,19 @@ TUPLE: timestamp
 C: <timestamp> timestamp
 
 : gmt-offset-duration ( -- duration )
-    0 0 0 gmt-offset <duration> ;
+    0 0 0 gmt-offset <duration> ; inline
 
 : <date> ( year month day -- timestamp )
-    0 0 0 gmt-offset-duration <timestamp> ;
+    0 0 0 gmt-offset-duration <timestamp> ; inline
 
 : <date-gmt> ( year month day -- timestamp )
-    0 0 0 instant <timestamp> ;
+    0 0 0 instant <timestamp> ; inline
 
 : <year> ( year -- timestamp )
-    1 1 <date> ;
+    1 1 <date> ; inline
 
 : <year-gmt> ( year -- timestamp )
-    1 1 <date-gmt> ;
+    1 1 <date-gmt> ; inline
 
 ERROR: not-a-month ;
 M: not-a-month summary
@@ -64,12 +64,6 @@ CONSTANT: month-names
         "July" "August" "September" "October" "November" "December"
     }
 
-<PRIVATE
-
-: (month-name) ( n -- string ) 1 - month-names nth ;
-
-PRIVATE>
-
 GENERIC: month-name ( obj -- string )
 
 M: integer month-name check-month 1 - month-names nth ;
@@ -161,13 +155,13 @@ M: timestamp easter ( timestamp -- timestamp )
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
-: years ( x -- duration ) instant clone swap >>year ;
+: years ( x -- duration ) instant swap >>year ;
-: months ( x -- duration ) instant clone swap >>month ;
+: months ( x -- duration ) instant swap >>month ;
-: days ( x -- duration ) instant clone swap >>day ;
+: days ( x -- duration ) instant swap >>day ;
 : weeks ( x -- duration ) 7 * days ;
-: hours ( x -- duration ) instant clone swap >>hour ;
+: hours ( x -- duration ) instant swap >>hour ;
-: minutes ( x -- duration ) instant clone swap >>minute ;
+: minutes ( x -- duration ) instant swap >>minute ;
-: seconds ( x -- duration ) instant clone swap >>second ;
+: seconds ( x -- duration ) instant swap >>second ;
 : milliseconds ( x -- duration ) 1000 / seconds ;
 : microseconds ( x -- duration ) 1000000 / seconds ;
 : nanoseconds ( x -- duration ) 1000000000 / seconds ;
@@ -315,13 +309,21 @@ GENERIC: time- ( time1 time2 -- time3 )
     gmt-offset-duration convert-timezone ;
 
 : >gmt ( timestamp -- timestamp' )
-    instant convert-timezone ;
+    dup gmt-offset>> dup instant =
+    [ drop ] [
+        [ neg +second 0 ] change-second
+        [ neg +minute 0 ] change-minute
+        [ neg +hour   0 ] change-hour
+        [ neg +day    0 ] change-day
+        [ neg +month  0 ] change-month
+        [ neg +year   0 ] change-year drop
+    ] if ;
 
 M: timestamp <=> ( ts1 ts2 -- n )
     [ >gmt tuple-slots ] compare ;
 
 : same-day? ( ts1 ts2 -- ? )
-    [ >gmt >date< <date> ] bi@ = ;
+    [ >gmt >date< <date> ] same? ;
 
 : (time-) ( timestamp timestamp -- n )
     [ >gmt ] bi@
@@ -348,33 +350,53 @@ M: timestamp time-
 : before ( duration -- -duration )
     -1 time* ;
 
+<PRIVATE
+
+: -slots ( obj1 obj2 quot -- n obj1 obj2 )
+    [ bi@ - ] curry 2keep ; inline
+
+PRIVATE>
+
 M: duration time-
-    before time+ ;
+    over timestamp? [
+        before time+
+    ] [
+        [ year>> ] -slots
+        [ month>> ] -slots
+        [ day>> ] -slots
+        [ hour>> ] -slots
+        [ minute>> ] -slots
+        [ second>> ] -slots
+        2drop <duration>
+    ] if ;
 
 : <zero> ( -- timestamp )
-    0 0 0 0 0 0 instant <timestamp> ;
+    0 0 0 <date-gmt> ; inline
 
 : valid-timestamp? ( timestamp -- ? )
     clone instant >>gmt-offset
     dup <zero> time- <zero> time+ = ;
 
 : unix-1970 ( -- timestamp )
-    1970 1 1 0 0 0 instant <timestamp> ;
+    1970 <year-gmt> ; inline
 
 : millis>timestamp ( x -- timestamp )
-    [ unix-1970 ] dip milliseconds time+ ;
+    [ unix-1970 ] dip 1000 / +second ;
 
 : timestamp>millis ( timestamp -- n )
     unix-1970 (time-) 1000 * >integer ;
 
 : micros>timestamp ( x -- timestamp )
-    [ unix-1970 ] dip microseconds time+ ;
+    [ unix-1970 ] dip 1000000 / +second ;
 
 : timestamp>micros ( timestamp -- n )
     unix-1970 (time-) 1000000 * >integer ;
 
-: now ( -- timestamp ) gmt >local-time ;
+: now ( -- timestamp )
+    gmt gmt-offset-duration (time+) >>gmt-offset ;
+
 : hence ( duration -- timestamp ) now swap time+ ;
+
 : ago ( duration -- timestamp ) now swap time- ;
 
 : zeller-congruence ( year month day -- n )
@@ -422,8 +444,11 @@ M: timestamp day-name day-of-week day-names nth ;
 : noon ( timestamp -- new-timestamp )
     midnight 12 >>hour ; inline
 
+: today ( -- timestamp )
+    now midnight ; inline
+
 : beginning-of-month ( timestamp -- new-timestamp )
-    midnight 1 >>day ;
+    midnight 1 >>day ; inline
 
 : end-of-month ( timestamp -- new-timestamp )
     [ midnight ] [ days-in-month ] bi >>day ;
@@ -438,7 +463,7 @@ M: timestamp day-name day-of-week day-names nth ;
 
 :: nth-day-this-month ( timestamp n day -- new-timestamp )
     timestamp beginning-of-month day day-this-week
-    dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
+    dup timestamp [ month>> ] same? [ 1 weeks time+ ] unless
     n 1 - [ weeks time+ ] unless-zero ;
 
 : last-day-this-month ( timestamp day -- new-timestamp )
@@ -529,21 +554,20 @@ M: timestamp end-of-year 12 >>month 31 >>day ;
 M: integer end-of-year 12 31 <date> ;
 
 : time-since-midnight ( timestamp -- duration )
-    dup midnight time- ;
+    dup midnight time- ; inline
 
 : since-1970 ( duration -- timestamp )
-    unix-1970 time+ ;
+    unix-1970 time+ ; inline
 
 : timestamp>unix-time ( timestamp -- seconds )
-    unix-1970 time- second>> ;
+    unix-1970 (time-) ; inline
 
 : unix-time>timestamp ( seconds -- timestamp )
-    seconds unix-1970 time+ ;
+    [ unix-1970 ] dip +second ; inline
-
-M: duration sleep
-    duration>nanoseconds >integer nano-count + sleep-until ;
 
 {
     { [ os unix? ] [ "calendar.unix" ] }
     { [ os windows? ] [ "calendar.windows" ] }
 } cond require
+
+{ "threads" "calendar" } "calendar.threads" require-when

basis/calendar/format/format.factor

@@ -205,7 +205,7 @@ ERROR: invalid-timestamp-format ;
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
-        " " read-token checked-number >>second
+        read-sp checked-number >>second
         readln parse-rfc822-gmt-offset >>gmt-offset ;
 
 : rfc822>timestamp ( str -- timestamp )
@@ -224,7 +224,7 @@ ERROR: invalid-timestamp-format ;
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
-        " " read-token checked-number >>second
+        read-sp checked-number >>second
         readln parse-rfc822-gmt-offset >>gmt-offset ;
 
 : cookie-string>timestamp-1 ( str -- timestamp )
@@ -237,7 +237,7 @@ ERROR: invalid-timestamp-format ;
         read-sp checked-number >>day
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
-        " " read-token checked-number >>second
+        read-sp checked-number >>second
         read-sp checked-number >>year
         readln parse-rfc822-gmt-offset >>gmt-offset ;
 
@@ -264,7 +264,7 @@ ERROR: invalid-timestamp-format ;
     [ (hms>timestamp) ] with-string-reader ;
 
 : (ymd>timestamp) ( -- timestamp )
-    read-ymd 0 0 0 instant <timestamp> ;
+    read-ymd <date-gmt> ;
 
 : ymd>timestamp ( str -- timestamp )
     [ (ymd>timestamp) ] with-string-reader ;
@@ -292,7 +292,7 @@ TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
         {
             MONTH " " DD " "
             [
-                dup now [ year>> ] bi@ =
+                dup now [ year>> ] same?
                 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
             ]
         } formatted

basis/calendar/threads/threads.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar math system threads ;
+IN: calendar.threads
+
+M: duration sleep
+    duration>nanoseconds >integer nano-count + sleep-until ;

basis/calendar/unix/unix.factor

@@ -1,27 +1,32 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax arrays calendar
+USING: accessors alien.data calendar calendar.private
-kernel math unix unix.time unix.types namespaces system
+classes.struct kernel math system unix unix.time unix.types ;
-accessors classes.struct ;
 IN: calendar.unix
 
+: timeval>seconds ( timeval -- seconds )
+    [ sec>> ] [ usec>> 1,000,000 / ] bi + ; inline
+
+: timeval>micros ( timeval -- micros )
+    [ sec>> 1,000,000 * ] [ usec>> ] bi + ; inline
+
 : timeval>duration ( timeval -- duration )
-    [ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
+    timeval>seconds seconds ; inline
 
 : timeval>unix-time ( timeval -- timestamp )
-    timeval>duration since-1970 ;
+    [ unix-1970 ] dip timeval>seconds +second ; inline
 
-: timespec>duration ( timespec -- seconds )
+: timespec>seconds ( timespec -- seconds )
-    [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
+    [ sec>> ] [ nsec>> 1,000,000,000 / ] bi + ; inline
 
-: timespec>nanoseconds ( timespec -- seconds )
+: timespec>duration ( timespec -- duration )
-    [ sec>> 1000000000 * ] [ nsec>> ] bi + ;
+    timespec>seconds seconds ; inline
 
 : timespec>unix-time ( timespec -- timestamp )
-    timespec>duration since-1970 ;
+    [ unix-1970 ] dip timespec>seconds +second ; inline
 
 : get-time ( -- alien )
-    f time <time_t> localtime ;
+    f time time_t <ref> localtime ; inline
 
 : timezone-name ( -- string )
     get-time zone>> ;
@@ -30,11 +35,10 @@ M: unix gmt-offset ( -- hours minutes seconds )
     get-time gmtoff>> 3600 /mod 60 /mod ;
 
 : current-timeval ( -- timeval )
-    timeval <struct> f [ gettimeofday io-error ] 2keep drop ;
+    timeval <struct> f [ gettimeofday io-error ] 2keep drop ; inline
 
 : system-micros ( -- n )
-    current-timeval
+    current-timeval timeval>micros ;
-    [ sec>> 1,000,000 * ] [ usec>> ] bi + ;
 
 M: unix gmt
     current-timeval timeval>unix-time ;

basis/channels/remote/remote-docs.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup channels concurrency.distributed ;
+USING: channels concurrency.distributed help.markup help.syntax
+io.servers ;
 IN: channels.remote
 
 HELP: <remote-channel>
@@ -45,9 +46,9 @@ HELP: publish
 ARTICLE: { "remote-channels" "remote-channels" } "Remote Channels"
 "Remote channels are channels that can be accessed by other Factor instances. It uses distributed concurrency to serialize and send data between channels."
 $nl
-"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-node } "."
+"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-server } "."
 $nl
-{ $snippet "\"myhost.com\" 9001 start-node" } 
+{ $snippet "\"myhost.com\" 9001 start-server" } 
 $nl
 "Once the node is started, channels can be published using " { $link publish }
 " to be accessed remotely. " { $link publish } " returns an id which a remote node "

basis/checksums/common/common.factor

@@ -14,8 +14,8 @@ SYMBOL: bytes-read
 
 : pad-last-block ( str big-endian? length -- str )
     [
-        [ % ] 2dip HEX: 80 ,
+        [ % ] 2dip 0x80 ,
-        [ HEX: 3f bitand calculate-pad-length <byte-array> % ]
+        [ 0x3f bitand calculate-pad-length <byte-array> % ]
         [ 3 shift 8 rot [ >be ] [ >le ] if % ] bi
     ] B{ } make 64 group ;
 

basis/checksums/fnv1/fnv1-docs.factor

@@ -43,7 +43,7 @@ HELP: fnv1a-1024
 { $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ;
 
 ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
-  "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
+  "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See " { $url "http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash" } " for more details."
 { $subsections
     fnv1-32
     fnv1a-32

basis/checksums/fnv1/fnv1-tests.factor

@@ -3,25 +3,25 @@ IN: checksums.fnv1.tests
 
 ! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c
 
-[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
+[ 0x811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
-[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
+[ 0x811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
-[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
+[ 0xcbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
-[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
+[ 0xcbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
 
-[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
+[ 0x050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
-[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
+[ 0xe40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
-[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
+[ 0xaf63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
-[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
+[ 0xaf63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
 
-[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
+[ 0x050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
-[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
+[ 0xe70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
-[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
+[ 0xaf63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
-[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
+[ 0xaf63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
 
-[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
+[ 0x31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
-[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
+[ 0xbf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
-[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
+[ 0x340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
-[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
+[ 0x85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
 
 ! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes.
 ! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop.

basis/checksums/fnv1/fnv1.factor

@@ -24,19 +24,19 @@ CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211
 CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759
 CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573
 
-CONSTANT: fnv1-32-mod HEX: ffffffff
+CONSTANT: fnv1-32-mod 0xffffffff
-CONSTANT: fnv1-64-mod HEX: ffffffffffffffff
+CONSTANT: fnv1-64-mod 0xffffffffffffffff
-CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-128-mod 0xffffffffffffffffffffffffffffffff
-CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-256-mod 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
-CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-512-mod 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
-CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-1024-mod 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
 
-CONSTANT: fnv1-32-basis HEX: 811c9dc5
+CONSTANT: fnv1-32-basis 0x811c9dc5
-CONSTANT: fnv1-64-basis HEX: cbf29ce484222325
+CONSTANT: fnv1-64-basis 0xcbf29ce484222325
-CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d
+CONSTANT: fnv1-128-basis 0x6c62272e07bb014262b821756295c58d
-CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
+CONSTANT: fnv1-256-basis 0xdd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
-CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
+CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
-CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
+CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
 
 M: fnv1-32 checksum-bytes ( bytes checksum -- value )
     drop

basis/checksums/hmac/hmac-tests.factor

@@ -15,8 +15,8 @@ IN: checksums.hmac.tests
     "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
 ]
 [
-    50 HEX: dd <repetition>
+    50 0xdd <repetition>
-    16 HEX: aa <string> md5 hmac-bytes >string
+    16 0xaa <string> md5 hmac-bytes >string
 ] unit-test
 
 [
@@ -34,12 +34,12 @@ IN: checksums.hmac.tests
 [
     "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
 ] [
-    50 HEX: dd <repetition>
+    50 0xdd <repetition>
-    16 HEX: aa <string> sha1 hmac-bytes >string
+    16 0xaa <string> sha1 hmac-bytes >string
 ] unit-test
 
 [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
-[ "Hi There" 20 HEX: b <string> sha-256 hmac-bytes hex-string ] unit-test
+[ "Hi There" 20 0xb <string> sha-256 hmac-bytes hex-string ] unit-test
 
 [ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
 [

basis/checksums/hmac/hmac.factor

@@ -9,9 +9,9 @@ IN: checksums.hmac
 
 : seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
 
-: opad ( checksum-state -- seq ) block-size>> HEX: 5c <array> ;
+: opad ( checksum-state -- seq ) block-size>> 0x5c <array> ;
 
-: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
+: ipad ( checksum-state -- seq ) block-size>> 0x36 <array> ;
 
 :: init-key ( checksum key checksum-state -- o i )
     checksum-state block-size>> key length <

basis/checksums/internet/internet-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax ;
+IN: checksums.internet
+
+HELP: internet
+{ $class-description "Internet (RFC1071) checksum algorithm." } ;
+
+ARTICLE: "checksums.internet" "Internet checksum"
+"The internet checksum algorithm implements RFC1071 (" { $url "http://www.ietf.org/rfc/rfc1141.txt" } ")."
+{ $subsections internet } ;
+
+ABOUT: "checksums.internet"

basis/checksums/internet/internet-tests.factor

@@ -12,10 +12,10 @@ IN: checksums
 
 : test-data ( -- bytes )
     B{
-        HEX: 00 HEX: 01
+        0x00 0x01
-        HEX: f2 HEX: 03
+        0xf2 0x03
-        HEX: f4 HEX: f5
+        0xf4 0xf5
-        HEX: f6 HEX: f7
+        0xf6 0xf7
     } ;
 
 [ B{ 34 13 } ] [ test-data internet checksum-bytes ] unit-test

basis/checksums/internet/internet.factor

@@ -11,6 +11,6 @@ INSTANCE: internet checksum
 
 M: internet checksum-bytes
     drop 0 swap 2 <sliced-groups> [ le> + ] each
-    [ -16 shift ] [ HEX: ffff bitand ] bi +
+    [ -16 shift ] [ 0xffff bitand ] bi +
     [ -16 shift ] keep + bitnot 2 >le ;
 

basis/checksums/md5/md5.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2006, 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math
+USING: alien.c-types alien.data kernel io io.binary io.files
-math.functions math.parser namespaces splitting grouping strings
+io.streams.byte-array math math.functions math.parser namespaces
-sequences byte-arrays locals sequences.private macros fry
+splitting grouping strings sequences byte-arrays locals
-io.encodings.binary math.bitwise checksums accessors
+sequences.private macros fry io.encodings.binary math.bitwise
-checksums.common checksums.stream combinators combinators.smart
+checksums accessors checksums.common checksums.stream
-specialized-arrays literals hints ;
+combinators combinators.smart specialized-arrays literals hints ;
+FROM: sequences.private => change-nth-unsafe ;
 SPECIALIZED-ARRAY: uint
 IN: checksums.md5
 
@@ -18,7 +19,7 @@ TUPLE: md5-state < checksum-state state old-state ;
 : <md5-state> ( -- md5 )
     md5-state new-checksum-state
         64 >>block-size
-        uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
+        uint-array{ 0x67452301 0xefcdab89 0x98badcfe 0x10325476 }
         [ clone >>state ] [ >>old-state ] bi ;
 
 M: md5 initialize-checksum-state drop <md5-state> ;
@@ -183,7 +184,7 @@ HINTS: (process-md5-block-I) { uint-array md5-state } ;
     ] unless ;
 
 : uint-array-cast-le ( byte-array -- uint-array )
-    byte-array>le uint-array-cast ;
+    byte-array>le uint cast-array ;
 
 HINTS: uint-array-cast-le byte-array ;
 

basis/checksums/sha/sha.factor

@@ -20,19 +20,19 @@ TUPLE: sha1-state < checksum-state K H W word-size ;
 
 CONSTANT: initial-H-sha1
     { 
-        HEX: 67452301
+        0x67452301
-        HEX: efcdab89
+        0xefcdab89
-        HEX: 98badcfe
+        0x98badcfe
-        HEX: 10325476
+        0x10325476
-        HEX: c3d2e1f0
+        0xc3d2e1f0
     }
 
 CONSTANT: K-sha1
     $[
-        20 HEX: 5a827999 <repetition>
+        20 0x5a827999 <repetition>
-        20 HEX: 6ed9eba1 <repetition>
+        20 0x6ed9eba1 <repetition>
-        20 HEX: 8f1bbcdc <repetition>
+        20 0x8f1bbcdc <repetition>
-        20 HEX: ca62c1d6 <repetition> 
+        20 0xca62c1d6 <repetition> 
         4 { } nappend-as
     ]
 
@@ -64,83 +64,83 @@ CONSTANT: h 7
 
 CONSTANT: initial-H-224
     {
-        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939
-        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+        0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4
     }
 
 CONSTANT: initial-H-256
     {
-        HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
+        0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a
-        HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
+        0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19
     }
 
 CONSTANT: initial-H-384
     {
-        HEX: cbbb9d5dc1059ed8
+        0xcbbb9d5dc1059ed8
-        HEX: 629a292a367cd507
+        0x629a292a367cd507
-        HEX: 9159015a3070dd17
+        0x9159015a3070dd17
-        HEX: 152fecd8f70e5939
+        0x152fecd8f70e5939
-        HEX: 67332667ffc00b31
+        0x67332667ffc00b31
-        HEX: 8eb44a8768581511
+        0x8eb44a8768581511
-        HEX: db0c2e0d64f98fa7
+        0xdb0c2e0d64f98fa7
-        HEX: 47b5481dbefa4fa4
+        0x47b5481dbefa4fa4
     }
 
 CONSTANT: initial-H-512
     {
-        HEX: 6a09e667f3bcc908
+        0x6a09e667f3bcc908
-        HEX: bb67ae8584caa73b
+        0xbb67ae8584caa73b
-        HEX: 3c6ef372fe94f82b
+        0x3c6ef372fe94f82b
-        HEX: a54ff53a5f1d36f1
+        0xa54ff53a5f1d36f1
-        HEX: 510e527fade682d1
+        0x510e527fade682d1
-        HEX: 9b05688c2b3e6c1f
+        0x9b05688c2b3e6c1f
-        HEX: 1f83d9abfb41bd6b
+        0x1f83d9abfb41bd6b
-        HEX: 5be0cd19137e2179
+        0x5be0cd19137e2179
     }
 
 CONSTANT: K-256
     {
-        HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
+        0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5
-        HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
+        0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5
-        HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
+        0xd807aa98 0x12835b01 0x243185be 0x550c7dc3
-        HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
+        0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174
-        HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
+        0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc
-        HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
+        0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da
-        HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
+        0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7
-        HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
+        0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967
-        HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
+        0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13
-        HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
+        0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85
-        HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
+        0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3
-        HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
+        0xd192e819 0xd6990624 0xf40e3585 0x106aa070
-        HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
+        0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5
-        HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
+        0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3
-        HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
+        0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208
-        HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
+        0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2
     }
 
 CONSTANT: K-384
     {
 
-        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        0x428a2f98d728ae22 0x7137449123ef65cd 0xb5c0fbcfec4d3b2f 0xe9b5dba58189dbbc 
-        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        0x3956c25bf348b538 0x59f111f1b605d019 0x923f82a4af194f9b 0xab1c5ed5da6d8118 
-        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
+        0xd807aa98a3030242 0x12835b0145706fbe 0x243185be4ee4b28c 0x550c7dc3d5ffb4e2
-        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        0x72be5d74f27b896f 0x80deb1fe3b1696b1 0x9bdc06a725c71235 0xc19bf174cf692694 
-        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        0xe49b69c19ef14ad2 0xefbe4786384f25e3 0x0fc19dc68b8cd5b5 0x240ca1cc77ac9c65 
-        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        0x2de92c6f592b0275 0x4a7484aa6ea6e483 0x5cb0a9dcbd41fbd4 0x76f988da831153b5 
-        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        0x983e5152ee66dfab 0xa831c66d2db43210 0xb00327c898fb213f 0xbf597fc7beef0ee4 
-        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        0xc6e00bf33da88fc2 0xd5a79147930aa725 0x06ca6351e003826f 0x142929670a0e6e70 
-        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        0x27b70a8546d22ffc 0x2e1b21385c26c926 0x4d2c6dfc5ac42aed 0x53380d139d95b3df 
-        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        0x650a73548baf63de 0x766a0abb3c77b2a8 0x81c2c92e47edaee6 0x92722c851482353b 
-        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        0xa2bfe8a14cf10364 0xa81a664bbc423001 0xc24b8b70d0f89791 0xc76c51a30654be30 
-        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        0xd192e819d6ef5218 0xd69906245565a910 0xf40e35855771202a 0x106aa07032bbd1b8 
-        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        0x19a4c116b8d2d0c8 0x1e376c085141ab53 0x2748774cdf8eeb99 0x34b0bcb5e19b48a8 
-        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        0x391c0cb3c5c95a63 0x4ed8aa4ae3418acb 0x5b9cca4f7763e373 0x682e6ff3d6b2b8a3 
-        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        0x748f82ee5defb2fc 0x78a5636f43172f60 0x84c87814a1f0ab72 0x8cc702081a6439ec 
-        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        0x90befffa23631e28 0xa4506cebde82bde9 0xbef9a3f7b2c67915 0xc67178f2e372532b 
-        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        0xca273eceea26619c 0xd186b8c721c0c207 0xeada7dd6cde0eb1e 0xf57d4f7fee6ed178 
-        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        0x06f067aa72176fba 0x0a637dc5a2c898a6 0x113f9804bef90dae 0x1b710b35131c471b 
-        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        0x28db77f523047d84 0x32caab7b40c72493 0x3c9ebe0a15c9bebc 0x431d67c49c100d4c 
-        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+        0x4cc5d4becb3e42b6 0x597f299cfc657e2a 0x5fcb6fab3ad6faec 0x6c44198c4a475817
     }
 
 ALIAS: K-512 K-384
@@ -308,17 +308,17 @@ M: sha2-short checksum-block
     [ prepare-message-schedule ]
     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 
-: seq>byte-array ( seq n -- string )
+: sequence>byte-array ( seq n -- string )
     '[ _ >be ] map B{ } concat-as ;
 
 : sha1>checksum ( sha2 -- bytes )
-    H>> 4 seq>byte-array ;
+    H>> 4 sequence>byte-array ;
 
 : sha-224>checksum ( sha2 -- bytes )
-    H>> 7 head 4 seq>byte-array ;
+    H>> 7 head 4 sequence>byte-array ;
 
 : sha-256>checksum ( sha2 -- bytes )
-    H>> 4 seq>byte-array ;
+    H>> 4 sequence>byte-array ;
 
 : pad-last-short-block ( state -- )
     [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri

basis/classes/struct/authors.txt

@@ -1 +1,4 @@
 Joe Groff
+Daniel Ehrenberg
+John Benediktsson
+Slava Pestov

basis/classes/struct/bit-accessors/bit-accessors-tests.factor

@@ -4,5 +4,5 @@ USING: classes.struct.bit-accessors tools.test effects kernel
 sequences random stack-checker ;
 IN: classes.struct.bit-accessors.test
 
-[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test
+[ t ] [ 20 random 20 random bit-reader infer ( alien -- n ) effect= ] unit-test
-[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test
+[ t ] [ 20 random 20 random bit-writer infer ( n alien -- ) effect= ] unit-test

basis/classes/struct/bit-accessors/bit-accessors.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math fry locals math.order alien.accessors ;
+USING: alien.accessors fry kernel locals math math.bitwise
+math.order sequences ;
 IN: classes.struct.bit-accessors
 
 ! Bitfield accessors are little-endian on all platforms
 ! Why not? It's unspecified in C
 
 : ones-between ( start end -- n )
-    [ 2^ 1 - ] bi@ swap bitnot bitand ;
+    [ on-bits ] bi@ swap unmask ;
 
 :: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
     offset 8 /mod :> ( i start-bit )
@@ -25,10 +26,10 @@ IN: classes.struct.bit-accessors
                     combine-quot: ( prev-quot shift-amount next-quot -- quot )
                     -- quot )
     offset bits step-quot manipulate-bits
-    dup zero? [ 3drop ] [
+    [ 2drop ] [
         step-quot combine-quot bit-manipulator
         combine-quot call( prev shift next -- quot )
-    ] if ; inline recursive
+    ] if-zero ; inline recursive
 
 : bit-reader ( offset bits -- quot: ( alien -- n ) )
     [ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ]

basis/classes/struct/prettyprint/prettyprint.factor

@@ -1,20 +1,25 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
+USING: accessors alien alien.c-types alien.data
-assocs classes classes.struct combinators combinators.short-circuit
+alien.prettyprint arrays assocs classes classes.struct
-continuations fry kernel libc make math math.parser mirrors
+combinators combinators.short-circuit continuations fry kernel
-prettyprint.backend prettyprint.custom prettyprint.sections
+libc make math math.parser mirrors prettyprint.backend
-see.private sequences slots strings summary words ;
+prettyprint.custom prettyprint.sections see.private sequences
+slots strings summary words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
 
 : struct-definer-word ( class -- word )
-    struct-slots dup length 2 >=
+    struct-slots
-    [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+    {
-    [ drop \ STRUCT: ] if ;
+        { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
+        { [ dup length 1 <= ] [ drop \ STRUCT: ] }
+        { [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-STRUCT: ] }
+        [ drop \ STRUCT: ]
+    } cond ;
 
 : struct>assoc ( struct -- assoc )
-    [ class struct-slots ] [ struct-slot-values ] bi zip ;
+    [ class-of struct-slots ] [ struct-slot-values ] bi zip ;
 
 : pprint-struct-slot ( slot -- )
     <flow \ { pprint-word
@@ -34,13 +39,13 @@ IN: classes.struct.prettyprint
 : pprint-struct ( struct -- )
     [
         [ \ S{ ] dip
-        [ class ]
+        [ class-of ]
         [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
         \ } (pprint-tuple)
     ] ?pprint-tuple ;
 
 : pprint-struct-pointer ( struct -- )
-    \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
+    \ S@ [ [ class-of pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
 
 PRIVATE>
 
@@ -53,7 +58,7 @@ M: struct pprint-delims
     drop \ S{ \ } ;
 
 M: struct >pprint-sequence
-    [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+    [ class-of ] [ struct-slot-values ] bi class-slot-sequence ;
 
 M: struct pprint*
     [ pprint-struct ]
@@ -61,7 +66,7 @@ M: struct pprint*
 
 M: struct summary
     [
-        dup class name>> %
+        dup class-of name>> %
         " struct of " %
         byte-length #
         " bytes " %
@@ -71,19 +76,19 @@ TUPLE: struct-mirror { object read-only } ;
 C: <struct-mirror> struct-mirror
 
 : get-struct-slot ( struct slot -- value present? )
-    over class struct-slots slot-named
+    over class-of struct-slots slot-named
     [ name>> reader-word execute( struct -- value ) t ]
     [ drop f f ] if* ;
 : set-struct-slot ( value struct slot -- )
-    over class struct-slots slot-named
+    over class-of struct-slots slot-named
     [ name>> writer-word execute( value struct -- ) ]
     [ 2drop ] if* ;
 : reset-struct-slot ( struct slot -- )
-    over class struct-slots slot-named
+    over class-of struct-slots slot-named
     [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
     [ drop ] if* ;
 : reset-struct-slots ( struct -- )
-    dup class struct-prototype
+    dup class-of struct-prototype
     dup byte-length memcpy ;
 
 M: struct-mirror at*

basis/classes/struct/struct-docs.factor

@@ -55,12 +55,23 @@ HELP: UNION-STRUCT:
 { $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
 { $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
 
+HELP: PACKED-STRUCT:
+{ $syntax "PACKED-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type with no alignment padding between slots or at the end. In all other respects, behaves like " { $link POSTPONE: STRUCT: } "." } ;
+
 HELP: define-struct-class
 { $values
     { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
 }
 { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
 
+HELP: define-packed-struct-class
+{ $values
+    { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: PACKED-STRUCT: } " syntax." } ;
+
 HELP: define-union-struct-class
 { $values
     { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
@@ -88,6 +99,10 @@ HELP: memory>struct
 }
 { $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
 
+HELP: read-struct
+{ $values { "class" class } { "struct" struct } }
+{ $description "Reads a new " { $link struct } " of the specified " { $snippet "class" } "." } ;
+
 HELP: struct
 { $class-description "The parent class of all struct types." } ;
 
@@ -110,18 +125,18 @@ ARTICLE: "classes.struct.examples" "Struct class examples"
 { $code "test-struct <struct> ." }
 "Creating a new instance with slots initialized from the stack:"
 { $code
-    "USING: libc specialized-arrays ;"
+    "USING: libc specialized-arrays alien.data ;"
     "SPECIALIZED-ARRAY: char"
     ""
     "42"
-    "\"Hello, chicken.\" >char-array"
+    "\"Hello, chicken.\" char >c-array"
     "1024 malloc"
     "test-struct <struct-boa> ."
 } ;
 
 ARTICLE: "classes.struct.define" "Defining struct classes"
 "Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:"
-{ $subsections POSTPONE: STRUCT: }
+{ $subsections POSTPONE: STRUCT: POSTPONE: PACKED-STRUCT: }
 "Union structs are also supported, which behave like structs but share the same memory for all the slots."
 { $subsections POSTPONE: UNION-STRUCT: } ;
 

basis/classes/struct/struct-tests.factor

@@ -1,12 +1,14 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.syntax ascii
+USING: accessors alien alien.c-types alien.data alien.syntax
-assocs byte-arrays classes.struct classes.tuple.parser
+ascii assocs byte-arrays classes.struct
-classes.tuple.private classes.tuple combinators compiler.tree.debugger
+classes.struct.prettyprint classes.struct.prettyprint.private
-compiler.units delegate destructors io.encodings.utf8 io.pathnames
+classes.tuple.parser classes.tuple.private classes.tuple
-io.streams.string kernel libc literals math mirrors namespaces
+combinators compiler.tree.debugger compiler.units delegate
-prettyprint prettyprint.config see sequences specialized-arrays
+destructors io.encodings.utf8 io.pathnames io.streams.string
-system tools.test parser lexer eval layouts generic.single classes
+kernel libc literals math mirrors namespaces prettyprint
-vocabs ;
+prettyprint.config see sequences specialized-arrays system
+tools.test parser lexer eval layouts generic.single classes
+vocabs generic classes.private definitions ;
 FROM: math => float ;
 FROM: specialized-arrays.private => specialized-array-vocab ;
 QUALIFIED-WITH: alien.c-types c
@@ -26,7 +28,7 @@ STRUCT: struct-test-foo
     { z bool } ;
 
 STRUCT: struct-test-bar
-    { w ushort initial: HEX: ffff }
+    { w ushort initial: 0xffff }
     { foo struct-test-foo } ;
 
 [ 12 ] [ struct-test-foo heap-size ] unit-test
@@ -51,7 +53,7 @@ STRUCT: struct-test-bar
 [ {
     { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
     { { "x" char } 98            }
-    { { "y" int  } HEX: 7F00007F }
+    { { "y" int  } 0x7F00007F }
     { { "z" bool } f             }
 } ] [
     B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
@@ -131,6 +133,9 @@ STRUCT: struct-test-bar
     [ make-mirror clear-assoc ] keep
 ] unit-test
 
+[ POSTPONE: STRUCT: ]
+[ struct-test-foo struct-definer-word ] unit-test
+
 UNION-STRUCT: struct-test-float-and-bits
     { f c:float }
     { bits uint } ;
@@ -140,6 +145,9 @@ UNION-STRUCT: struct-test-float-and-bits
 
 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 
+[ POSTPONE: UNION-STRUCT: ]
+[ struct-test-float-and-bits struct-definer-word ] unit-test
+
 STRUCT: struct-test-string-ptr
     { x c-string } ;
 
@@ -153,36 +161,30 @@ STRUCT: struct-test-string-ptr
 
 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
 [
-    [
+    H{ { boa-tuples? f } { c-object-pointers? f } } [
-        boa-tuples? off
-        c-object-pointers? off
         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
-    ] with-scope
+    ] with-variables
 ] unit-test
 
 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
 [
-    [
+    H{ { c-object-pointers? t } } [
-        c-object-pointers? on
         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
-    ] with-scope
+    ] with-variables
 ] unit-test
 
 [ "S{ struct-test-foo f 0 7654 f }" ]
 [
-    [
+    H{ { boa-tuples? t } { c-object-pointers? f } } [
-        boa-tuples? on
-        c-object-pointers? off
         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
-    ] with-scope
+    ] with-variables
 ] unit-test
 
 [ "S@ struct-test-foo f" ]
 [
-    [
+    H{ { c-object-pointers? f } } [
-        c-object-pointers? off
         f struct-test-foo memory>struct [ pprint ] with-string-writer
-    ] with-scope
+    ] with-variables
 ] unit-test
 
 [ "USING: alien.c-types classes.struct ;
@@ -221,7 +223,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { type bool }
         { class object }
     }
-} ] [ struct-test-foo c-type fields>> ] unit-test
+} ] [ struct-test-foo lookup-c-type fields>> ] unit-test
 
 [ {
     T{ struct-slot-spec
@@ -238,7 +240,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { class $[ cell 4 = integer fixnum ? ] }
         { initial 0 }
     }
-} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
+} ] [ struct-test-float-and-bits lookup-c-type fields>> ] unit-test
 
 STRUCT: struct-test-equality-1
     { x int } ;
@@ -265,7 +267,7 @@ STRUCT: struct-test-equality-2
     [
         struct-test-equality-1 <struct> 5 >>x
         struct-test-equality-1 malloc-struct &free 5 >>x
-        [ hashcode ] bi@ =
+        [ hashcode ] same?
     ] with-destructors
 ] unit-test
 
@@ -289,7 +291,7 @@ SPECIALIZED-ARRAY: struct-test-optimization
 
 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 [ t ] [
-    [ 3 <direct-struct-test-optimization-array> third y>> ]
+    [ 3 struct-test-optimization <c-direct-array> third y>> ]
     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 ] unit-test
 
@@ -297,7 +299,7 @@ SPECIALIZED-ARRAY: struct-test-optimization
 
 [ t ] [
     [ struct-test-optimization memory>struct x>> second ]
-    { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
+    { memory>struct x>> int <c-direct-array> <tuple> <tuple-boa> } inlined?
 ] unit-test
 
 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
@@ -320,7 +322,7 @@ STRUCT: clone-test-struct { x int } { y char[3] } ;
     clone-test-struct <struct>
     1 >>x char-array{ 9 1 1 } >>y
     clone
-    [ x>> ] [ y>> >char-array ] bi
+    [ x>> ] [ y>> char >c-array ] bi
 ] unit-test
 
 [ t 1 char-array{ 9 1 1 } ] [
@@ -328,7 +330,7 @@ STRUCT: clone-test-struct { x int } { y char[3] } ;
         clone-test-struct malloc-struct &free
         1 >>x char-array{ 9 1 1 } >>y
         clone
-        [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
+        [ >c-ptr byte-array? ] [ x>> ] [ y>> char >c-array ] tri
     ] with-destructors
 ] unit-test
 
@@ -460,8 +462,8 @@ cpu ppc? [
         { y int }
         { x longlong } ;
 
-    [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
+    [ 16 ] [ ppc-align-test-2 heap-size ] unit-test
-    [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+    [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test
 ] when
 
 STRUCT: struct-test-delegate
@@ -482,3 +484,62 @@ SPECIALIZED-ARRAY: void*
 STRUCT: silly-array-field-test { x int*[3] } ;
 
 [ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
+
+! Packed structs
+PACKED-STRUCT: packed-struct-test
+    { d c:int }
+    { e c:short }
+    { f c:int }
+    { g c:char }
+    { h c:int } ;
+
+[ 15 ] [ packed-struct-test heap-size ] unit-test
+
+[ 0 ] [ "d" packed-struct-test offset-of ] unit-test
+[ 4 ] [ "e" packed-struct-test offset-of ] unit-test
+[ 6 ] [ "f" packed-struct-test offset-of ] unit-test
+[ 10 ] [ "g" packed-struct-test offset-of ] unit-test
+[ 11 ] [ "h" packed-struct-test offset-of ] unit-test
+
+[ POSTPONE: PACKED-STRUCT: ]
+[ packed-struct-test struct-definer-word ] unit-test
+
+STRUCT: struct-1 { a c:int } ;
+PACKED-STRUCT: struct-1-packed { a c:int } ;
+UNION-STRUCT: struct-1-union { a c:int } ;
+
+[ "USING: alien.c-types classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-1 { a int initial: 0 } ;
+" ]
+[ \ struct-1 [ see ] with-string-writer ] unit-test
+[ "USING: alien.c-types classes.struct ;
+IN: classes.struct.tests
+PACKED-STRUCT: struct-1-packed { a int initial: 0 } ;
+" ]
+[ \ struct-1-packed [ see ] with-string-writer ] unit-test
+[ "USING: alien.c-types classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-1-union { a int initial: 0 } ;
+" ]
+[ \ struct-1-union [ see ] with-string-writer ] unit-test
+
+! Bug #206
+STRUCT: going-to-redefine { a uint } ;
+[ ] [
+    "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
+] unit-test
+[ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test
+[ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test
+
+! Test reset-class on structs, which should forget all the accessors, clone, and struct-slot-values
+STRUCT: some-accessors { aaa uint } { bbb int } ;
+[ ] [ [ \ some-accessors reset-class ] with-compilation-unit ] unit-test
+[ f ] [ \ some-accessors \ a>> ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ a<< ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ b>> ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ b<< ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ clone ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ struct-slot-values ?lookup-method ] unit-test
+
+<< \ some-accessors forget >>

basis/classes/struct/struct.factor

@@ -1,15 +1,15 @@
-! (c)Joe Groff, Daniel Ehrenberg bsd license
+! Copyright (C) 2010, 2011 Joe Groff, Daniel Ehrenberg,
+! John Benediktsson, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
 USING: accessors alien alien.c-types alien.data alien.parser
-arrays byte-arrays classes classes.private classes.parser
+arrays byte-arrays classes classes.parser classes.private
-classes.tuple classes.tuple.parser classes.tuple.private
+classes.struct.bit-accessors classes.tuple classes.tuple.parser
-combinators combinators.short-circuit combinators.smart
+combinators combinators.smart cpu.architecture definitions fry
-cpu.architecture definitions functors.backend fry
+functors.backend generalizations generic generic.parser io kernel
-generalizations generic.parser kernel kernel.private lexer libc
+kernel.private lexer libc locals macros math math.order parser
-locals macros make math math.order parser quotations sequences
+quotations sequences slots slots.private specialized-arrays
-slots slots.private specialized-arrays vectors words summary
+stack-checker.dependencies summary vectors vocabs.loader
-namespaces assocs vocabs.parser math.functions
+vocabs.parser words ;
-classes.struct.bit-accessors bit-arrays
-stack-checker.dependencies system layouts ;
 FROM: delegate.private => group-words slot-group-words ;
 QUALIFIED: math
 IN: classes.struct
@@ -24,8 +24,11 @@ M: struct-must-have-slots summary
 TUPLE: struct
     { (underlying) c-ptr read-only } ;
 
+! We hijack the core slots vocab's slot-spec type for struct
+! fields. Note that 'offset' is in bits, not bytes, to support
+! bitfields.
 TUPLE: struct-slot-spec < slot-spec
-    type ;
+    type packed? ;
 
 ! For a struct-bit-slot-spec, offset is in bits, not bytes
 TUPLE: struct-bit-slot-spec < struct-slot-spec
@@ -49,7 +52,7 @@ M: struct >c-ptr
 
 M: struct equal?
     over struct? [
-        2dup [ class ] bi@ = [
+        2dup [ class-of ] same? [
             2dup [ >c-ptr ] both?
             [ [ >c-ptr ] [ binary-object ] bi* memory= ]
             [ [ >c-ptr not ] both? ]
@@ -59,7 +62,7 @@ M: struct equal?
 
 M: struct hashcode*
     binary-object over
-    [ <direct-uchar-array> hashcode* ] [ 3drop 0 ] if ; inline
+    [ uchar <c-direct-array> hashcode* ] [ 3drop 0 ] if ; inline
 
 : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
 
@@ -68,6 +71,9 @@ M: struct hashcode*
     ! optimized down to efficient code if it is.
     '[ _ boa ] call( ptr -- struct ) ; inline
 
+: read-struct ( class -- struct )
+    [ heap-size read ] [ memory>struct ] bi ;
+
 <PRIVATE
 : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
     '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
@@ -133,11 +139,11 @@ M: struct-bit-slot-spec (writer-quot)
     drop [ >c-ptr ] ;
 
 MACRO: read-struct-slot ( slot -- )
-    dup type>> depends-on-c-type
+    dup type>> add-depends-on-c-type
     (reader-quot) ;
 
 MACRO: write-struct-slot ( slot -- )
-    dup type>> depends-on-c-type
+    dup type>> add-depends-on-c-type
     (writer-quot) ;
 PRIVATE>
 
@@ -146,7 +152,7 @@ M: struct-class boa>object
     [ <struct> ] [ struct-slots ] bi
     [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
 
-M: struct-class initial-value* <struct> ; inline
+M: struct-class initial-value* <struct> t ; inline
 
 ! Struct slot accessors
 
@@ -170,7 +176,7 @@ TUPLE: struct-c-type < abstract-c-type
 
 INSTANCE: struct-c-type value-type
 
-M: struct-c-type c-type ;
+M: struct-c-type lookup-c-type ;
 
 M: struct-c-type base-type ;
 
@@ -192,6 +198,9 @@ M: struct-c-type base-type ;
     [ \ struct-slot-values ] [ struct-slot-values-quot ] bi
     define-inline-method ;
 
+: forget-struct-slot-values-method ( class -- )
+    \ struct-slot-values ?lookup-method forget ;
+
 : clone-underlying ( struct -- byte-array )
     binary-object memory>byte-array ; inline
 
@@ -200,6 +209,9 @@ M: struct-c-type base-type ;
     [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
     define-inline-method ;
 
+: forget-clone-method ( class -- )
+    \ clone ?lookup-method forget ;
+
 :: c-type-for-class ( class slots size align -- c-type )
     struct-c-type new
         byte-array >>class
@@ -213,11 +225,14 @@ M: struct-c-type base-type ;
 
 GENERIC: compute-slot-offset ( offset class -- offset' )
 
-: c-type-align-at ( class offset -- n )
+: c-type-align-at ( slot-spec offset -- n )
-    0 = [ c-type-align-first ] [ c-type-align ] if ;
+    over packed?>> [ 2drop 1 ] [
+        [ type>> ] dip
+        0 = [ c-type-align-first ] [ c-type-align ] if
+    ] if ;
 
 M: struct-slot-spec compute-slot-offset
-    [ type>> over c-type-align-at 8 * align ] keep
+    [ over c-type-align-at 8 * align ] keep
     [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
 
 M: struct-bit-slot-spec compute-slot-offset
@@ -231,12 +246,12 @@ M: struct-bit-slot-spec compute-slot-offset
 
 : struct-alignment ( slots -- align )
     [ struct-bit-slot-spec? not ] filter
-    1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+    1 [ dup offset>> c-type-align-at max ] reduce ;
 
 PRIVATE>
 
-M: struct byte-length class "struct-size" word-prop ; foldable
+M: struct byte-length class-of "struct-size" word-prop ; foldable
-M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
+M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inline
 
 ! class definition
 
@@ -262,17 +277,17 @@ M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
     bi ;
 
 : check-struct-slots ( slots -- )
-    [ type>> c-type drop ] each ;
+    [ type>> lookup-c-type drop ] each ;
 
 : redefine-struct-tuple-class ( class -- )
     [ struct f define-tuple-class ] [ make-final ] bi ;
 
-:: (define-struct-class) ( class slots offsets-quot -- )
+:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
-    slots empty? [ struct-must-have-slots ] when
+    slot-specs check-struct-slots
+    slot-specs empty? [ struct-must-have-slots ] when
     class redefine-struct-tuple-class
-    slots make-slots dup check-struct-slots :> slot-specs
     slot-specs offsets-quot call :> unaligned-size
-    slot-specs struct-alignment :> alignment
+    slot-specs alignment-quot call :> alignment
     unaligned-size alignment align :> size
 
     class slot-specs size alignment c-type-for-class :> c-type
@@ -282,20 +297,44 @@ M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
     class size "struct-size" set-word-prop
     class dup make-struct-prototype "prototype" set-word-prop
     class (struct-methods) ; inline
+
+: make-packed-slots ( slots -- slot-specs )
+    make-slots [ t >>packed? ] map! ;
+
 PRIVATE>
 
 : define-struct-class ( class slots -- )
-    [ compute-struct-offsets ] (define-struct-class) ;
+    make-slots
+    [ compute-struct-offsets ] [ struct-alignment ]
+    (define-struct-class) ;
+
+: define-packed-struct-class ( class slots -- )
+    make-packed-slots
+    [ compute-struct-offsets ] [ drop 1 ]
+    (define-struct-class) ;
 
 : define-union-struct-class ( class slots -- )
-    [ compute-union-offsets ] (define-struct-class) ;
+    make-slots
+    [ compute-union-offsets ] [ struct-alignment ]
+    (define-struct-class) ;
 
 ERROR: invalid-struct-slot token ;
 
 : struct-slot-class ( c-type -- class' )
-    c-type c-type-boxed-class
+    lookup-c-type c-type-boxed-class
     dup \ byte-array = [ drop \ c-ptr ] when ;
 
+M: struct-class reset-class
+    {
+        [ dup "c-type" word-prop fields>> forget-slot-accessors ]
+        [
+            [ forget-struct-slot-values-method ]
+            [ forget-clone-method ] bi
+        ]
+        [ { "c-type" "layout" "struct-size" } reset-props ]
+        [ call-next-method ]
+    } cleave ;
+
 SYMBOL: bits:
 
 <PRIVATE
@@ -331,12 +370,12 @@ PRIVATE>
 : <struct-slot-spec> ( name c-type attributes -- slot-spec )
     [ struct-slot-spec new ] 3dip
     [ >>name ]
-    [ [ >>type ] [ struct-slot-class >>class ] bi ]
+    [ [ >>type ] [ struct-slot-class init-slot-class ] bi ]
     [ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ;
 
 <PRIVATE
 : parse-struct-slot ( -- slot )
-    scan scan-c-type \ } parse-until <struct-slot-spec> ;
+    scan-token scan-c-type \ } parse-until <struct-slot-spec> ;
 
 : parse-struct-slots ( slots -- slots' more? )
     scan-token {
@@ -346,12 +385,16 @@ PRIVATE>
     } case ;
 
 : parse-struct-definition ( -- class slots )
-    CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
+    scan-new-class 8 <vector> [ parse-struct-slots ] [ ] while >array
     dup [ name>> ] map check-duplicate-slots ;
 PRIVATE>
 
 SYNTAX: STRUCT:
     parse-struct-definition define-struct-class ;
+
+SYNTAX: PACKED-STRUCT:
+    parse-struct-definition define-packed-struct-class ;
+
 SYNTAX: UNION-STRUCT:
     parse-struct-definition define-union-struct-class ;
 
@@ -365,18 +408,19 @@ SYNTAX: S@
 
 <PRIVATE
 : scan-c-type` ( -- c-type/param )
-    scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
+    scan-token dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
 
 : parse-struct-slot` ( accum -- accum )
     scan-string-param scan-c-type` \ } parse-until
     [ <struct-slot-spec> suffix! ] 3curry append! ;
 
 : parse-struct-slots` ( accum -- accum more? )
-    scan {
+    scan-token {
         { ";" [ f ] }
         { "{" [ parse-struct-slot` t ] }
         [ invalid-struct-slot ]
     } case ;
+
 PRIVATE>
 
 FUNCTOR-SYNTAX: STRUCT:
@@ -385,6 +429,4 @@ FUNCTOR-SYNTAX: STRUCT:
     [ parse-struct-slots` ] [ ] while
     [ >array define-struct-class ] append! ;
 
-USING: vocabs vocabs.loader ;
-
 { "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when

basis/cocoa/application/application.factor

@@ -17,7 +17,7 @@ CONSTANT: NSApplicationDelegateReplyFailure 2
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 
-CONSTANT: NSAnyEventMask HEX: ffffffff
+CONSTANT: NSAnyEventMask 0xffffffff
 
 FUNCTION: void NSBeep ( ) ;