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

Factor.app/Contents/Info.plist

@@ -31,8 +31,10 @@
 	<string>Factor</string>
 	<key>CFBundlePackageType</key>
 	<string>APPL</string>
+	<key>CFBundleVersion</key>
+	<string>0.93</string>
 	<key>NSHumanReadableCopyright</key>
-	<string>Copyright © 2003-2009, Slava Pestov and friends</string>
+	<string>Copyright © 2003-2010 Factor developers</string>
 	<key>NSServices</key>
 	<array>
 		<dict>

GNUmakefile

@@ -4,7 +4,7 @@ ifdef CONFIG
 	AR = ar
 	LD = ld
 
-	VERSION = 0.92
+	VERSION = 0.93
 
 	BUNDLE = Factor.app
 	LIBPATH = -L/usr/X11R6/lib
@@ -52,6 +52,7 @@ ifdef CONFIG
 		vm/io.o \
 		vm/jit.o \
 		vm/math.o \
+		vm/mvm.o \
 		vm/nursery_collector.o \
 		vm/object_start_map.o \
 		vm/objects.o \
@@ -168,22 +169,16 @@ macosx.app: factor
 	mkdir -p $(BUNDLE)/Contents/Frameworks
 	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
 	ln -s Factor.app/Contents/MacOS/factor ./factor
-	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
-
-	install_name_tool \
-		-change libfactor.dylib \
-		@executable_path/../Frameworks/libfactor.dylib \
-		Factor.app/Contents/MacOS/factor
 
 $(ENGINE): $(DLL_OBJS)
 	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
 
-factor: $(EXE_OBJS) $(ENGINE)
+factor: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
 
-factor-console: $(EXE_OBJS) $(ENGINE)
+factor-console: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
 
 factor-ffi-test: $(FFI_TEST_LIBRARY)

Nmakefile

@@ -1,15 +1,27 @@
-!IF DEFINED(DEBUG)
+!IF DEFINED(PLATFORM)
-LINK_FLAGS = /nologo /DEBUG shell32.lib
+
-CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
-!ELSE
 LINK_FLAGS = /nologo shell32.lib
 CL_FLAGS = /nologo /O2 /W3
+
+!IF DEFINED(DEBUG)
+LINK_FLAGS = $(LINK_FLAGS) /DEBUG
+CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
 !ENDIF
 
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+!IF "$(PLATFORM)" == "x86-32"
+LINK_FLAGS = $(LINK_FLAGS) /safeseh
+PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
+!ELSEIF "$(PLATFORM)" == "x86-64"
+PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
+!ENDIF
 
-DLL_OBJS = vm\os-windows-nt.obj \
+ML_FLAGS = /nologo /safeseh
+
+EXE_OBJS = vm\main-windows-nt.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 \
@@ -38,6 +50,8 @@ DLL_OBJS = vm\os-windows-nt.obj \
 	vm\io.obj \
 	vm\jit.obj \
 	vm\math.obj \
+	vm\mvm.obj \
+	vm\mvm-windows-nt.obj \
 	vm\nursery_collector.obj \
 	vm\object_start_map.obj \
 	vm\objects.obj \
@@ -58,22 +72,40 @@ DLL_OBJS = vm\os-windows-nt.obj \
 .c.obj:
 	cl $(CL_FLAGS) /Fo$@ /c $<
 
+.asm.obj:
+	ml $(ML_FLAGS) /Fo$@ /c $<
+
 .rs.res:
 	rc $<
 
-all: factor.com factor.exe libfactor-ffi-test.dll
-
 libfactor-ffi-test.dll: vm/ffi_test.obj
 	link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
 
 factor.dll.lib: $(DLL_OBJS)
 	link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
 
-factor.com: $(EXE_OBJS)
+factor.com: $(EXE_OBJS) $(DLL_OBJS)
-	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
 
-factor.exe: $(EXE_OBJS)
+factor.exe: $(EXE_OBJS) $(DLL_OBJS)
-	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
+
+all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
+
+!ENDIF
+
+default:
+	@echo Usage: nmake /f Nmakefile platform
+	@echo Where platform is one of:
+	@echo x86-32
+	@echo x86-64
+	@exit 1
+
+x86-32:
+	nmake PLATFORM=x86-32 /f Nmakefile all
+
+x86-64:
+	nmake PLATFORM=x86-64 /f Nmakefile all
 
 clean:
 	del vm\*.obj
@@ -83,6 +115,6 @@ clean:
 	del factor.dll
 	del factor.dll.lib
 
-.PHONY: all clean
+.PHONY: all default x86-32 x86-64 clean
 
 .SUFFIXES: .rs

basis/alarms/alarms-tests.factor

@@ -11,7 +11,6 @@ IN: alarms.tests
 ] unit-test
 
 [ ] [
-    [
+    self [ resume ] curry instant later drop
-        [ resume ] curry instant later drop
+    "test" suspend drop
-    ] "test" suspend drop
 ] unit-test

basis/alien/arrays/arrays.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.strings alien.c-types alien.data alien.accessors
+USING: alien alien.strings alien.c-types alien.accessors
 arrays words sequences math kernel namespaces fry cpu.architecture
-io.encodings.utf8 accessors ;
+io.encodings.binary io.encodings.utf8 accessors compiler.units ;
 IN: alien.arrays
 
 INSTANCE: array value-type
@@ -34,16 +34,8 @@ M: array box-return drop void* box-return ;
 
 M: array stack-size drop void* stack-size ;
 
-M: array c-type-boxer-quot
-    unclip
-    [ array-length ]
-    [ [ require-c-array ] keep ] bi*
-    [ <c-direct-array> ] 2curry ;
-
-M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-
 PREDICATE: string-type < pair
-    first2 [ char* = ] [ word? ] bi* and ;
+    first2 [ c-string = ] [ word? ] bi* and ;
 
 M: string-type c-type ;
 
@@ -88,10 +80,14 @@ M: string-type c-type-unboxer
     drop void* c-type-unboxer ;
 
 M: string-type c-type-boxer-quot
-    second '[ _ alien>string ] ;
+    second dup binary =
+    [ drop void* c-type-boxer-quot ]
+    [ '[ _ alien>string ] ] if ;
 
 M: string-type c-type-unboxer-quot
-    second '[ _ string>alien ] ;
+    second dup binary =
+    [ drop void* c-type-unboxer-quot ]
+    [ '[ _ string>alien ] ] if ;
 
 M: string-type c-type-getter
     drop [ alien-cell ] ;
@@ -99,8 +95,5 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
-{ char* utf8 } char* typedef
+[ { c-string utf8 } c-string typedef ] with-compilation-unit
-char* uchar* typedef
 
-char char* "pointer-c-type" set-word-prop
-uchar uchar* "pointer-c-type" set-word-prop

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

@@ -6,10 +6,6 @@ QUALIFIED: math
 QUALIFIED: sequences
 IN: alien.c-types
 
-HELP: byte-length
-{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
-{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
-
 HELP: heap-size
 { $values { "name" "a C type name" } { "size" math:integer } }
 { $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
@@ -32,13 +28,10 @@ HELP: no-c-type
 { $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." } ;
 
-HELP: c-types
-{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
-
 HELP: c-type
 { $values { "name" "a C type" } { "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." } ;
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
 
 HELP: c-getter
 { $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
@@ -106,8 +99,8 @@ HELP: ulonglong
 HELP: void
 { $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
 HELP: void*
-{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
+{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
-HELP: char*
+HELP: c-string
 { $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
 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." } ;
@@ -118,6 +111,19 @@ HELP: complex-float
 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."
+$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
+"In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:"
+{ $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" }
+{ $unchecked-example """: foo ( bar -- int* )
+    pointer: int f \"foo\" { pointer: char } alien-invoke ;""" } } ;
 
 ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
 "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
@@ -194,11 +200,11 @@ ARTICLE: "c-types.primitives" "Primitive C types"
 "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"
-"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
+"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. This syntax constructs a " { $link pointer } " object to represent the C type."
 $nl
 "Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
 { $code "int[3][4]" }
-"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
+"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however, when used as function parameters, they behave exactly like pointers with the dimensions only serving as documentation." ;
 
 ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
 "Note that some of the C type word names clash with commonly-used Factor words:"
@@ -231,7 +237,7 @@ ARTICLE: "c-types.structs" "Struct and union types"
 "Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
 
 ARTICLE: "c-types-specs" "C type specifiers"
-"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
+"C types are identified by special words. Type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
 $nl
 "Defining new C types:"
 { $subsections

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

@@ -1,6 +1,6 @@
 USING: alien alien.syntax alien.c-types alien.parser
 eval kernel tools.test sequences system libc alien.strings
-io.encodings.utf8 math.constants classes.struct classes
+io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
 accessors compiler.units ;
 IN: alien.c-types.tests
 
@@ -16,36 +16,39 @@ UNION-STRUCT: foo
     { a int }
     { b int } ;
 
-[ f ] [ char  resolve-pointer-type c-type void* c-type eq? ] unit-test
+[ t ] [ pointer: void c-type void* c-type = ] unit-test
-[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
+[ t ] [ pointer: int  c-type void* c-type = ] unit-test
+[ t ] [ pointer: int* c-type void* c-type = ] unit-test
+[ f ] [ pointer: foo  c-type void* c-type = ] unit-test
+[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
+
+[ t ] [ c-string c-type c-string c-type = ] unit-test
 
 [ t ] [ foo heap-size int heap-size = ] unit-test
 
 TYPEDEF: int MyInt
 
-[ t ] [ int   c-type MyInt                      c-type eq? ] unit-test
+[ t ] [ int   c-type          MyInt c-type = ] unit-test
-[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
-
-TYPEDEF: char MyChar
-
-[ t ] [ char  c-type MyChar                      c-type eq? ] unit-test
-[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
-[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
 
 [ 32 ] [ { int 8 } heap-size ] unit-test
 
-TYPEDEF: char* MyString
+TYPEDEF: char MyChar
 
-[ t ] [ char* c-type MyString                      c-type eq? ] unit-test
+[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
-[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
+
+TYPEDEF: { c-string ascii } MyFunkyString
+
+[ { c-string ascii } ] [ MyFunkyString c-type ] unit-test
+
+TYPEDEF: c-string MyString
+
+[ t ] [ c-string c-type MyString          c-type = ] unit-test
+[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
 
 TYPEDEF: int* MyIntArray
 
-[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
+[ t ] [ void* c-type MyIntArray c-type = ] unit-test
-
-TYPEDEF: uchar* MyLPBYTE
-
-[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
 
 [
     0 B{ 1 2 3 4 } <displaced-alien> <void*>
@@ -63,7 +66,7 @@ os windows? cpu x86.64? and [
 
 C-TYPE: opaque
 
-[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
 [ opaque c-type ] [ no-c-type? ] must-fail-with
 
 [ """

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

@@ -17,8 +17,9 @@ SYMBOLS:
     long ulong
     longlong ulonglong
     float double
-    void* bool
+    void* bool ;
-    void ;
+
+SINGLETON: void
 
 DEFER: <int>
 DEFER: *char
@@ -43,65 +44,24 @@ stack-align? ;
 : <c-type> ( -- c-type )
     \ c-type new ; inline
 
-SYMBOL: c-types
-
-global [
-    c-types [ H{ } assoc-like ] change
-] bind
-
 ERROR: no-c-type name ;
 
-PREDICATE: c-type-word < word
-    "c-type" word-prop ;
-
-UNION: c-type-name string c-type-word ;
-
 ! C type protocol
 GENERIC: c-type ( name -- c-type ) foldable
 
-GENERIC: resolve-pointer-type ( name -- c-type )
+PREDICATE: c-type-word < word
+    "c-type" word-prop ;
 
-<< \ void \ void* "pointer-c-type" set-word-prop >>
+TUPLE: pointer { to initial: void read-only } ;
+C: <pointer> pointer
 
-: void? ( c-type -- ? )
+UNION: c-type-name
-    { void "void" } member? ;
+    c-type-word pointer ;
-
-M: word resolve-pointer-type
-    dup "pointer-c-type" word-prop
-    [ ] [ drop void* ] ?if ;
-
-M: string resolve-pointer-type
-    dup "*" append dup c-types get at
-    [ nip ] [
-        drop
-        c-types get at dup c-type-name?
-        [ resolve-pointer-type ] [ drop void* ] if
-    ] if ;
-
-M: array resolve-pointer-type
-    first resolve-pointer-type ;
 
 : resolve-typedef ( name -- c-type )
     dup void? [ no-c-type ] when
     dup c-type-name? [ c-type ] when ;
 
-<PRIVATE
-
-: parse-array-type ( name -- dims c-type )
-    "[" split unclip
-    [ [ "]" ?tail drop string>number ] map ] dip ;
-
-PRIVATE>
-
-M: string c-type ( name -- c-type )
-    CHAR: ] over member? [
-        parse-array-type prefix
-    ] [
-        dup c-types get at [ ] [
-            "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
-        ] ?if resolve-typedef
-    ] if ;
-
 M: word c-type
     dup "c-type" word-prop resolve-typedef
     [ ] [ no-c-type ] ?if ;
@@ -233,12 +193,6 @@ M: c-type-name stack-size c-type stack-size ;
 
 M: c-type stack-size size>> cell align ;
 
-GENERIC: byte-length ( seq -- n ) flushable
-
-M: byte-array byte-length length ; inline
-
-M: f byte-length drop 0 ; inline
-
 : >c-bool ( ? -- int ) 1 0 ? ; inline
 
 : c-bool> ( int -- ? ) 0 = not ; inline
@@ -263,24 +217,13 @@ MIXIN: value-type
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
     ] [ ] make ;
 
-GENERIC: typedef ( old new -- )
-
 PREDICATE: typedef-word < c-type-word
     "c-type" word-prop c-type-name? ;
 
-M: string typedef ( old new -- ) c-types get set-at ;
+: typedef ( old new -- )
-
-M: word typedef ( old new -- )
     {
         [ nip define-symbol ]
-        [ name>> typedef ]
         [ swap "c-type" set-word-prop ]
-        [
-            swap dup c-type-name? [
-                resolve-pointer-type
-                "pointer-c-type" set-word-prop
-            ] [ 2drop ] if
-        ]
     } 2cleave ;
 
 TUPLE: long-long-type < c-type ;
@@ -315,6 +258,10 @@ M: long-long-type box-return ( c-type -- )
 : if-void ( c-type true false -- )
     pick void? [ drop nip call ] [ nip call ] if ; inline
 
+SYMBOLS:
+    ptrdiff_t intptr_t uintptr_t size_t
+    c-string ;
+
 CONSTANT: primitive-types
     {
         char uchar
@@ -324,11 +271,30 @@ CONSTANT: primitive-types
         longlong ulonglong
         float double
         void* bool
+        c-string
     }
 
-SYMBOLS:
+: (pointer-c-type) ( void* type -- void*' )
-    ptrdiff_t intptr_t uintptr_t size_t
+    [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
-    char* uchar* ;
+
+<PRIVATE
+
+: resolve-pointer-typedef ( type -- base-type )
+    dup "c-type" word-prop dup word?
+    [ nip resolve-pointer-typedef ] [
+        pointer? [ drop void* ] when
+    ] if ;
+
+: primitive-pointer-type? ( type -- ? )
+    dup c-type-word? [
+        resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
+    ] [ drop t ] if ;
+
+PRIVATE>
+
+M: pointer c-type
+    [ \ void* c-type ] dip
+    to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
 
 : 8-byte-alignment ( c-type -- c-type )
     {
@@ -541,6 +507,7 @@ SYMBOLS:
         \ uint c-type \ uintptr_t typedef
         \ uint c-type \ size_t typedef
     ] if
+
 ] with-compilation-unit
 
 M: char-16-rep rep-component-type drop char ;

basis/alien/complex/complex-tests.factor

@@ -16,6 +16,6 @@ STRUCT: complex-holder
 
 [ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
 
-[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
+[ complex ] [ complex-float c-type-boxed-class ] unit-test
 
-[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
+[ complex ] [ complex-double c-type-boxed-class ] unit-test

basis/alien/complex/complex.factor

@@ -6,8 +6,10 @@ IN: alien.complex
 
 <<
 { "float" "double" } [ dup "complex-" prepend define-complex-type ] each
+>>
 
+<<
 ! This overrides the fact that small structures are never returned
 ! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
-"complex-float" c-type t >>return-in-registers? drop
+\ complex-float c-type t >>return-in-registers? drop
 >>

basis/alien/complex/functor/functor.factor

@@ -7,6 +7,8 @@ IN: alien.complex.functor
 
 FUNCTOR: define-complex-type ( N T -- )
 
+N-type IS ${N}
+
 T-class DEFINES-CLASS ${T}
 
 <T> DEFINES <${T}>
@@ -14,7 +16,7 @@ T-class DEFINES-CLASS ${T}
 
 WHERE
 
-STRUCT: T-class { real N } { imaginary N } ;
+STRUCT: T-class { real N-type } { imaginary N-type } ;
 
 : <T> ( z -- alien )
     >rect T-class <struct-boa> >c-ptr ;

basis/alien/data/data-docs.factor

@@ -21,11 +21,6 @@ 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: byte-array>memory
-{ $values { "byte-array" byte-array } { "base" c-ptr } }
-{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
-{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
-
 HELP: malloc-array
 { $values { "n" "a non-negative integer" } { "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> } "." }
@@ -65,6 +60,8 @@ $nl
 }
 "You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
 { $subsections free }
+"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:"
+{ $subsections (free) }
 "Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
 { $subsections
     &free
@@ -75,9 +72,7 @@ $nl
 "You can unsafely copy a range of bytes from one memory location to another:"
 { $subsections memcpy }
 "You can copy a range of bytes from memory into a byte array:"
-{ $subsections memory>byte-array }
+{ $subsections memory>byte-array } ;
-"You can copy a byte array to memory unsafely:"
-{ $subsections byte-array>memory } ;
 
 ARTICLE: "c-pointers" "Passing pointers to C functions"
 "The following Factor objects may be passed to C function parameters with pointer types:"
@@ -85,7 +80,7 @@ ARTICLE: "c-pointers" "Passing pointers to C functions"
     { "Instances of " { $link alien } "." }
     { "Instances of " { $link f } "; this is interpreted as a null pointer." }
     { "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
-    { "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." } 
+    { "Any data type which defines a method on " { $link >c-ptr } ". This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
 }
 "The class of primitive C pointer types:"
 { $subsections c-ptr }
@@ -111,7 +106,7 @@ $nl
 { $subsections "byte-arrays-gc" }
 "C-style enumerated types are supported:"
 { $subsections POSTPONE: C-ENUM: }
-"C types can be aliased for convenience and consitency with native library documentation:"
+"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" }
@@ -140,13 +135,13 @@ HELP: <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." } ;
 
 ARTICLE: "c-strings" "C strings"
-"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
+"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."
 $nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+"Passing a Factor string to a C function expecting a " { $link c-string } " allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
 $nl
 "If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
 $nl
-"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
+"Care must be taken if the C function expects a pointer to a string with its length represented by another parameter rather than a null terminator. Passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
 $nl
 "Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
 { $subsections
@@ -155,7 +150,9 @@ $nl
 }
 "The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
 $nl
+"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
+$nl
 "A word to read strings from arbitrary addresses:"
 { $subsections alien>string }
-"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;
+"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." ;
 

basis/alien/data/data.factor

@@ -1,7 +1,8 @@
-! (c)2009 Slava Pestov, Joe Groff bsd license
+! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.strings arrays
+USING: accessors alien alien.c-types alien.arrays alien.strings arrays
 byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words ;
+io.files io.streams.memory kernel libc math sequences words
+byte-vectors ;
 IN: alien.data
 
 GENERIC: require-c-array ( c-type -- )
@@ -48,7 +49,7 @@ M: word <c-direct-array>
     heap-size malloc ; inline
 
 : malloc-byte-array ( byte-array -- alien )
-    dup byte-length [ nip malloc dup ] 2keep memcpy ;
+    binary-object [ nip malloc dup ] 2keep memcpy ;
 
 : memory>byte-array ( alien len -- byte-array )
     [ nip (byte-array) dup ] 2keep memcpy ;
@@ -62,8 +63,12 @@ M: memory-stream stream-read
         swap memory>byte-array
     ] [ [ + ] change-index drop ] 2bi ;
 
-: byte-array>memory ( byte-array base -- )
+M: byte-vector stream-write
-    swap dup byte-length memcpy ; inline
+    [ dup byte-length tail-slice ]
+    [ [ [ byte-length ] bi@ + ] keep lengthen ]
+    [ drop byte-length ]
+    2tri
+    [ >c-ptr swap >c-ptr ] dip memcpy ;
 
 M: value-type c-type-rep drop int-rep ;
 
@@ -73,3 +78,9 @@ M: value-type c-type-getter
 M: value-type c-type-setter ( type -- quot )
     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
     '[ @ swap @ _ memcpy ] ;
+
+M: array c-type-boxer-quot
+    unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
+
+M: array c-type-unboxer-quot drop [ >c-ptr ] ;
+

basis/alien/debugger/authors.txt

@@ -0,0 +1 @@
+Joe Groff

basis/alien/debugger/debugger.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2010 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.parser summary sequences accessors
+prettyprint ;
+IN: alien.debugger
+
+M: no-c-type summary name>> unparse "“" "” is not a C type" surround ;
+
+M: *-in-c-type-name summary
+    name>> "Cannot define a C type “" "” that ends with an asterisk (*)" surround ;

basis/alien/fortran/fortran-tests.factor

@@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
 classes.struct arrays assocs byte-arrays combinators fry
 generalizations io.encodings.ascii kernel macros
 macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
+FROM: alien.syntax => pointer: ;
 QUALIFIED-WITH: alien.c-types c
 IN: alien.fortran.tests
 
@@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
 
     ! fortran-arg-type>c-type
 
-    [ c:void* { } ]
+    [ pointer: c:int { } ]
     [ "integer" fortran-arg-type>c-type ] unit-test
 
-    [ c:void* { } ]
+    [ pointer: { c:int 3 } { } ]
     [ "integer(3)" fortran-arg-type>c-type ] unit-test
 
-    [ c:void* { } ]
+    [ pointer: { c:int 0 } { } ]
     [ "integer(*)" fortran-arg-type>c-type ] unit-test
 
-    [ c:void* { } ]
+    [ pointer: fortran_test_record { } ]
     [
         [
             "alien.fortran.tests" use-vocab
@@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
         ] with-manifest
     ] unit-test
 
-    [ c:char* { } ]
+    [ pointer: c:char { } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ c:char* { } ]
+    [ pointer: c:char { } ]
     [ "character(1)" fortran-arg-type>c-type ] unit-test
 
-    [ c:char* { long } ]
+    [ pointer: { c:char 17 } { long } ]
     [ "character(17)" fortran-arg-type>c-type ] unit-test
 
     ! fortran-ret-type>c-type
@@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
     [ c:char { } ]
     [ "character(1)" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:char* long } ]
+    [ c:void { pointer: { c:char 17 } long } ]
     [ "character(17)" fortran-ret-type>c-type ] unit-test
 
     [ c:int { } ]
@@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
     [ c:float { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: { c:float 0 } } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ c:double { } ]
     [ "double-precision" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: complex-float } ]
     [ "complex" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: complex-double } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: { c:int 0 } } ]
     [ "integer(*)" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: fortran_test_record } ]
     [
         [
             "alien.fortran.tests" use-vocab
@@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
 
     ! fortran-sig>c-sig
 
-    [ c:float { c:void* c:char* c:void* c:void* c:long } ]
+    [ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
     [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
     unit-test
 
-    [ c:char { c:char* c:char* c:void* c:long } ]
+    [ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
     [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
-    [ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
+    [ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
     [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
-    [ c:void { c:void* c:char* c:char* c:void* c:long } ]
+    [ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
     [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
@@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [ 
             c:void "funpack" "funtimes_"
-            { c:char* c:void* c:void* c:void* c:void* c:long }
+            { pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
             alien-invoke
         ] 6 nkeep
         ! [fortran-results>]
@@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
             [ { [ drop ] } spread ]
         } 1 ncleave
         ! [fortran-invoke]
-        [ c:float "funpack" "fun_times_" { void* } alien-invoke ]
+        [ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
         1 nkeep
         ! [fortran-results>]
         shuffle( reta aa -- reta aa ) 
@@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [
             c:void "funpack" "fun_times_"
-            { void* void* } 
+            { pointer: complex-float pointer: { c:float 0 } } 
             alien-invoke
         ] 2 nkeep
         ! [fortran-results>]
@@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [
             c:void "funpack" "fun_times_"
-            { c:char* long } 
+            { pointer: { c:char 20 } long } 
             alien-invoke
         ] 2 nkeep
         ! [fortran-results>]
@@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
         ! [fortran-invoke]
         [
             c:void "funpack" "fun_times_"
-            { c:char* long c:char* c:void* c:char* c:long c:long } 
+            { pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long } 
             alien-invoke
         ] 7 nkeep
         ! [fortran-results>]
@@ -321,16 +322,16 @@ f2c-abi fortran-abi [
     [ { c:char 1 } ]
     [ "character(1)" fortran-type>c-type ] unit-test
 
-    [ c:char* { c:long } ]
+    [ pointer: c:char { c:long } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ c:void { c:char* c:long } ]
+    [ c:void { pointer: c:char c:long } ]
     [ "character" fortran-ret-type>c-type ] unit-test
 
     [ c:double { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { void* } ]
+    [ c:void { pointer: { c:float 0 } } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
@@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
     [ c:float { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { void* } ]
+    [ c:void { pointer: { c:float 0 } } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ complex-float { } ]
@@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
     [ { char 1 } ]
     [ "character(1)" fortran-type>c-type ] unit-test
 
-    [ c:char* { c:long } ]
+    [ pointer: c:char { c:long } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ c:void { c:char* c:long } ]
+    [ c:void { pointer: c:char c:long } ]
     [ "character" fortran-ret-type>c-type ] unit-test
 
     [ complex-float { } ]
@@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
     [ complex-double { } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ c:void { c:void* } ]
+    [ c:void { pointer: { complex-double 3 } } ]
     [ "double-complex(3)" fortran-ret-type>c-type ] unit-test
 
 ] with-variable

basis/alien/fortran/fortran.factor

@@ -13,8 +13,8 @@ SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
 
 << 
 : add-f2c-libraries ( -- )
-    "I77" "libI77.so" "cdecl" add-library
+    "I77" "libI77.so" cdecl add-library
-    "F77" "libF77.so" "cdecl" add-library ;
+    "F77" "libF77.so" cdecl add-library ;
 
 os netbsd? [ add-f2c-libraries ] when
 >>
@@ -42,11 +42,11 @@ library-fortran-abis [ H{ } clone ] initialize
     [ "__" append ] [ "_" append ] if ;
 
 HOOK: fortran-c-abi fortran-abi ( -- abi )
-M: f2c-abi fortran-c-abi "cdecl" ;
+M: f2c-abi fortran-c-abi cdecl ;
-M: g95-abi fortran-c-abi "cdecl" ;
+M: g95-abi fortran-c-abi cdecl ;
-M: gfortran-abi fortran-c-abi "cdecl" ;
+M: gfortran-abi fortran-c-abi cdecl ;
-M: intel-unix-abi fortran-c-abi "cdecl" ;
+M: intel-unix-abi fortran-c-abi cdecl ;
-M: intel-windows-abi fortran-c-abi "cdecl" ;
+M: intel-windows-abi fortran-c-abi cdecl ;
 
 HOOK: real-functions-return-double? fortran-abi ( -- ? )
 M: f2c-abi real-functions-return-double? t ;
@@ -392,13 +392,13 @@ PRIVATE>
 
 : fortran-arg-type>c-type ( fortran-type -- c-type added-args )
     parse-fortran-type
-    [ (fortran-type>c-type) resolve-pointer-type ]
+    [ (fortran-type>c-type) <pointer> ]
     [ added-c-args ] bi ;
 : fortran-ret-type>c-type ( fortran-type -- c-type added-args )
     parse-fortran-type dup returns-by-value?
     [ (fortran-ret-type>c-type) { } ] [
         c:void swap 
-        [ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
+        [ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
     ] if ;
 
 : fortran-arg-types>c-types ( fortran-types -- c-types )
@@ -434,15 +434,15 @@ MACRO: fortran-invoke ( return library function parameters -- )
     [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
 
 SYNTAX: SUBROUTINE: 
-    f "c-library" get scan ";" parse-tokens
+    f current-library get scan ";" parse-tokens
     [ "()" subseq? not ] filter define-fortran-function ;
 
 SYNTAX: FUNCTION:
-    scan "c-library" get scan ";" parse-tokens
+    scan current-library get scan ";" parse-tokens
     [ "()" subseq? not ] filter define-fortran-function ;
 
 SYNTAX: LIBRARY:
     scan
-    [ "c-library" set ]
+    [ current-library set ]
     [ set-fortran-abi ] bi ;
 

basis/alien/libraries/authors.txt

@@ -1 +1,2 @@
 Slava Pestov
+Joe Groff

basis/alien/libraries/libraries-docs.factor

@@ -6,7 +6,7 @@ IN: alien.libraries
 
 HELP: <library>
 { $values
-     { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
+     { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
      { "library" library } }
 { $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
 { $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
@@ -19,7 +19,7 @@ HELP: library
 { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
     { $list
         { { $snippet "name" } " - the full path of the C library binary" }
-        { { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
+        { { $snippet "abi" } " - the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
         { { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
     }
 } ;
@@ -43,7 +43,7 @@ HELP: load-library
 { $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
 
 HELP: add-library
-{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
+{ $values { "name" string } { "path" string } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } }
 { $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
 { $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
 $nl
@@ -53,13 +53,17 @@ $nl
 { $examples "Here is a typical usage of " { $link add-library } ":"
 { $code
     "<< \"freetype\" {"
-    "    { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
+    "    { [ os macosx? ] [ \"libfreetype.6.dylib\" cdecl add-library ] }"
-    "    { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+    "    { [ os windows? ] [ \"freetype6.dll\" cdecl add-library ] }"
     "    [ drop ]"
     "} cond >>"
 }
 "Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
 
+HELP: deploy-library
+{ $values { "name" string } }
+{ $description "Specifies that the logical library named " { $snippet "name" } " should be included during " { $link "tools.deploy" } ". " { $snippet "name" } " must be the name of a library previously loaded with " { $link add-library } "." } ;
+
 HELP: remove-library
 { $values { "name" string } }
 { $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
@@ -72,4 +76,9 @@ ARTICLE: "loading-libs" "Loading native libraries"
 }
 "Once a library has been defined, you can try loading it to see if the path name is correct:"
 { $subsections load-library }
-"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
+"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again."
+$nl
+"Libraries that do not come standard with the operating system need to be included with deployed applications that use them. A word is provided to instruct " { $link "tools.deploy" } " that a library must be so deployed:"
+{ $subsections
+    deploy-library
+} ;

basis/alien/libraries/libraries.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.strings assocs io.backend
-kernel namespaces destructors ;
+kernel namespaces destructors sequences system io.pathnames ;
 IN: alien.libraries
 
 : dlopen ( path -- dll ) native-string>alien (dlopen) ;
@@ -14,6 +14,8 @@ libraries [ H{ } clone ] initialize
 
 TUPLE: library path abi dll ;
 
+ERROR: no-library name ;
+
 : library ( name -- library ) libraries get at ;
 
 : <library> ( path abi -- library )
@@ -32,3 +34,35 @@ M: library dispose dll>> [ dispose ] when* ;
 : add-library ( name path abi -- )
     [ 2drop remove-library ]
     [ <library> swap libraries get set-at ] 3bi ;
+
+: library-abi ( library -- abi )
+    library [ abi>> ] [ cdecl ] if* ;
+
+ERROR: no-such-symbol name library ;
+
+: address-of ( name library -- value )
+    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
+
+SYMBOL: deploy-libraries
+
+deploy-libraries [ V{ } clone ] initialize
+
+: deploy-library ( name -- )
+    dup libraries get key?
+    [ 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 ;
+
+M: unix >deployed-library-path
+    file-name "$ORIGIN" prepend-path ;
+
+M: macosx >deployed-library-path
+    file-name "@executable_path/../Frameworks" prepend-path ;
+
+PRIVATE>

basis/alien/parser/authors.txt

@@ -0,0 +1,3 @@
+Slava Pestov
+Doug Coleman
+Joe Groff

basis/alien/parser/parser-tests.factor

@@ -1,7 +1,7 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors alien.c-types alien.parser alien.syntax
-tools.test vocabs.parser parser eval vocabs.parser debugger
+tools.test vocabs.parser parser eval debugger kernel
-continuations ;
+continuations words ;
 IN: alien.parser.tests
 
 TYPEDEF: char char2
@@ -18,22 +18,28 @@ CONSTANT: eleven 11
     [ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
     [ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
     [ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
-    [ void* ] [ "int*" parse-c-type ] unit-test
+    [ pointer: void ] [ "void*" parse-c-type ] unit-test
-    [ void* ] [ "int**" parse-c-type ] unit-test
+    [ pointer: int ] [ "int*" parse-c-type ] unit-test
-    [ void* ] [ "int***" parse-c-type ] unit-test
+    [ pointer: int* ] [ "int**" parse-c-type ] unit-test
-    [ void* ] [ "int****" parse-c-type ] unit-test
+    [ pointer: int** ] [ "int***" parse-c-type ] unit-test
-    [ char* ] [ "char*" parse-c-type ] unit-test
+    [ pointer: int*** ] [ "int****" parse-c-type ] unit-test
-    [ void* ] [ "char**" parse-c-type ] unit-test
+    [ c-string ] [ "c-string" parse-c-type ] unit-test
-    [ void* ] [ "char***" parse-c-type ] unit-test
-    [ void* ] [ "char****" parse-c-type ] unit-test
     [ char2 ] [ "char2" parse-c-type ] unit-test
-    [ char* ] [ "char2*" parse-c-type ] unit-test
+    [ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
 
-    [ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
     [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
-
 ] with-file-vocabs
 
+FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
+[ (( arg1 arg2 -- void* )) ] [
+    \ alien-parser-function-effect-test "declared-effect" word-prop
+] unit-test
+
+CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ;
+[ (( arg1 arg2 -- void* )) ] [
+    \ alien-parser-callback-effect-test "callback-effect" word-prop
+] unit-test
+
 ! Reported by mnestic
 TYPEDEF: int alien-parser-test-int ! reasonably unique name...
 

basis/alien/parser/parser.factor

@@ -1,12 +1,14 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.parser
+USING: accessors alien alien.c-types alien.libraries arrays
-alien.libraries arrays assocs classes combinators
+assocs classes combinators combinators.short-circuit
-combinators.short-circuit compiler.units effects grouping
+compiler.units effects grouping kernel parser sequences
-kernel parser sequences splitting words fry locals lexer
+splitting words fry locals lexer namespaces summary math
-namespaces summary math vocabs.parser ;
+vocabs.parser words.constant ;
 IN: alien.parser
 
+SYMBOL: current-library
+
 : parse-c-type-name ( name -- word )
     dup search [ ] [ no-word ] ?if ;
 
@@ -18,101 +20,143 @@ IN: alien.parser
     {
         { [ dup "void" =         ] [ drop void ] }
         { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
+        { [ "*" ?tail            ] [ (parse-c-type) <pointer> ] }
         { [ dup search           ] [ parse-c-type-name ] }
-        { [ "**" ?tail           ] [ drop void* ] }
-        { [ "*" ?tail            ] [ parse-c-type-name resolve-pointer-type ] }
         [ dup search [ ] [ no-word ] ?if ]
     } cond ;
 
 : valid-c-type? ( c-type -- ? )
-    { [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
+    { [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
 
 : parse-c-type ( string -- type )
     (parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
 
 : scan-c-type ( -- c-type )
-    scan dup "{" =
+    scan {
-    [ drop \ } parse-until >array ]
+        { [ dup "{" = ] [ drop \ } parse-until >array ] }
-    [ parse-c-type ] if ; 
+        { [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
+        [ parse-c-type ]
+    } cond ; 
 
 : reset-c-type ( word -- )
     dup "struct-size" word-prop
     [ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
     {
         "c-type"
-        "pointer-c-type"
         "callback-effect"
         "callback-library"
     } reset-props ;
 
-: CREATE-C-TYPE ( -- word )
+ERROR: *-in-c-type-name name ;
-    scan current-vocab create {
+
+: validate-c-type-name ( name -- name )
+    dup "*" tail?
+    [ *-in-c-type-name ] when ;
+
+: (CREATE-C-TYPE) ( word -- word )
+    validate-c-type-name current-vocab create {
         [ fake-definition ]
         [ set-word ]
         [ reset-c-type ]
         [ ]
     } cleave ;
 
-: normalize-c-arg ( type name -- type' name' )
+: CREATE-C-TYPE ( -- word )
-    [ length ]
+    scan (CREATE-C-TYPE) ;
-    [
-        [ CHAR: * = ] trim-head
-        [ length - CHAR: * <array> append ] keep
-    ] bi
-    [ parse-c-type ] dip ;
 
-: parse-arglist ( parameters return -- types effect )
+<PRIVATE
-    [
+GENERIC: return-type-name ( type -- name )
-        2 group [ first2 normalize-c-arg 2array ] map
+
-        unzip [ "," ?tail drop ] map
+M: object return-type-name drop "void" ;
-    ]
+M: word return-type-name name>> ;
-    [ [ { } ] [ 1array ] if-void ]
+M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
-    bi* <effect> ;
+
+: parse-pointers ( type name -- type' name' )
+    "*" ?head
+    [ [ <pointer> ] dip parse-pointers ] when ;
+
+PRIVATE>
+
+: define-enum-member ( word-string value -- next-value )
+     [ create-in ] dip [ define-constant ] keep 1 + ;
+
+: parse-enum-member ( word-string value -- next-value )
+     over "{" =
+     [ 2drop scan scan-object define-enum-member "}" expect ]
+     [ define-enum-member ] if ;
+
+: parse-enum-members ( counter -- )
+     scan dup ";" = not
+     [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
+
+: scan-function-name ( -- return function )
+    scan-c-type scan parse-pointers ;
+
+:: (scan-c-args) ( end-marker types names -- )
+    scan :> type-str
+    type-str end-marker = [
+        type-str { "(" ")" } member? [
+            type-str parse-c-type :> type
+            scan "," ?tail drop :> name
+            type name parse-pointers :> ( type' name' )
+            type' types push name' names push
+        ] unless
+        end-marker types names (scan-c-args)
+    ] unless ;
+
+: scan-c-args ( end-marker -- types names )
+    V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return! library function! parameters -- word quot effect )
+: function-effect ( names return -- effect )
-    return function normalize-c-arg function! return!
+    [ { } ] [ return-type-name 1array ] if-void <effect> ;
-    function create-in dup reset-generic
-    return library function
-    parameters return parse-arglist [ function-quot ] dip ;
 
-: parse-arg-tokens ( -- tokens )
+: create-function ( name -- word )
-    ";" parse-tokens [ "()" subseq? not ] filter ;
+    create-in dup reset-generic ;
 
-: (FUNCTION:) ( -- word quot effect )
+:: (make-function) ( return function library types names -- quot effect )
-    scan "c-library" get scan parse-arg-tokens make-function ;
+    return library function types function-quot
+    names return function-effect ;
 
-: define-function ( return library function parameters -- )
+:: make-function ( return function library types names -- word quot effect )
-    make-function define-declared ;
+    function create-function
+    return function library types names (make-function) ;
+
+: (FUNCTION:) ( -- return function library types names )
+    scan-function-name current-library get ";" scan-c-args ;
 
 : callback-quot ( return types abi -- quot )
-    [ [ ] 3curry dip alien-callback ] 3curry ;
+    '[ [ _ _ _ ] dip alien-callback ] ;
 
-: library-abi ( lib -- abi )
+:: make-callback-type ( lib return type-name types names -- word quot effect )
-    library [ abi>> ] [ "cdecl" ] if* ;
-
-:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
-    return type-name normalize-c-arg type-name! return!
     type-name current-vocab create :> type-word 
     type-word [ reset-generic ] [ reset-c-type ] bi
     void* type-word typedef
-    parameters return parse-arglist :> ( types callback-effect )
+    type-word names return function-effect "callback-effect" set-word-prop
-    type-word callback-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 )) ;
 
 : (CALLBACK:) ( -- word quot effect )
-    "c-library" get
+    current-library get
-    scan scan parse-arg-tokens make-callback-type ;
+    scan-function-name ";" scan-c-args make-callback-type ;
 
-PREDICATE: alien-function-word < word
+PREDICATE: alien-function-alias-word < word
     def>> {
         [ length 5 = ]
         [ last \ alien-invoke eq? ]
     } 1&& ;
 
+PREDICATE: alien-function-word < alien-function-alias-word
+    [ def>> third ] [ name>> ] bi = ;
+
 PREDICATE: alien-callback-type-word < typedef-word
     "callback-effect" word-prop ;
 
+: global-quot ( type word -- quot )
+    name>> current-library get '[ _ _ address-of 0 ]
+    swap c-type-getter-boxer append ;
+
+: define-global ( type word -- )
+    [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

basis/alien/prettyprint/prettyprint.factor

@@ -19,12 +19,25 @@ M: c-type-word definer drop \ C-TYPE: f ;
 M: c-type-word definition drop f ;
 M: c-type-word declarations. drop ;
 
+<PRIVATE
+GENERIC: pointer-string ( pointer -- string/f )
+M: object pointer-string drop f ;
+M: word pointer-string name>> ;
+M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
+PRIVATE>
+
 GENERIC: pprint-c-type ( c-type -- )
 M: word pprint-c-type pprint-word ;
+M: pointer pprint-c-type
+    dup pointer-string
+    [ swap present-text ]
+    [ pprint* ] if* ;
 M: wrapper pprint-c-type wrapped>> pprint-word ;
 M: string pprint-c-type text ;
 M: array pprint-c-type pprint* ;
 
+M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
+
 M: typedef-word definer drop \ TYPEDEF: f ;
 
 M: typedef-word synopsis*
@@ -48,22 +61,36 @@ M: typedef-word synopsis*
 : pprint-library ( library -- )
     [ \ LIBRARY: [ text ] pprint-prefix ] when* ;
 
+: pprint-function ( word quot -- )
+    [ def>> first pprint-c-type ]
+    swap
+    [
+        <block "(" text
+        [ def>> fourth ] [ stack-effect in>> ] bi
+        pprint-function-args
+        ")" text block>
+    ] tri ; inline
+
+M: alien-function-alias-word definer
+    drop \ FUNCTION-ALIAS: \ ; ;
+M: alien-function-alias-word definition drop f ;
+M: alien-function-alias-word synopsis*
+    {
+        [ seeing-word ]
+        [ def>> second pprint-library ]
+        [ definer. ]
+        [ pprint-word ]
+        [ [ def>> third text ] pprint-function ]
+    } cleave ;
+
 M: alien-function-word definer
     drop \ FUNCTION: \ ; ;
-M: alien-function-word definition drop f ;
 M: alien-function-word synopsis*
     {
         [ seeing-word ]
         [ def>> second pprint-library ]
         [ definer. ]
-        [ def>> first pprint-c-type ]
+        [ [ pprint-word ] pprint-function ]
-        [ pprint-word ]
-        [
-            <block "(" text
-            [ def>> fourth ] [ stack-effect in>> ] bi
-            pprint-function-args
-            ")" text block>
-        ]
     } cleave ;
 
 M: alien-callback-type-word definer

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

@@ -6,14 +6,14 @@ eval ;
 IN: alien.remote-control
 
 : eval-callback ( -- callback )
-    void* { char* } "cdecl"
+    void* { c-string } cdecl
     [ eval>string utf8 malloc-string ] alien-callback ;
 
 : yield-callback ( -- callback )
-    void { } "cdecl" [ yield ] alien-callback ;
+    void { } cdecl [ yield ] alien-callback ;
 
 : sleep-callback ( -- callback )
-    void { long } "cdecl" [ sleep ] alien-callback ;
+    void { long } cdecl [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
     dup optimized? [ execute ] [ drop f ] if ; inline

basis/alien/syntax/syntax-docs.factor

@@ -26,9 +26,9 @@ HELP: LIBRARY:
 { $notes "Logical library names are defined with the " { $link add-library } " word." } ;
 
 HELP: FUNCTION:
-{ $syntax "FUNCTION: return name ( parameters )" }
+{ $syntax "FUNCTION: return name ( parameters ) ;" }
 { $values { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
+{ $description "Defines a new word " { $snippet "name" } " which calls the C library function with the same " { $snippet "name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
 $nl
 "The new word must be compiled before being executed." }
 { $examples
@@ -40,44 +40,56 @@ $nl
 }
 "You can define a word for invoking it:"
 { $unchecked-example
-    "LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
+    "LIBRARY: foo\nFUNCTION: void the_answer ( c-string question, int value ) ;"
-    "USE: compiler"
     "\"the question\" 42 the_answer"
     "The answer to the question is 42."
 } }
-{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
+"Using the " { $link c-string } " type instead of " { $snippet "char*" } " causes the FFI to automatically convert Factor strings to C strings. See " { $link "c-strings" } " for more information on using strings with the FFI."
+{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration easier to read. The following definitions are equivalent:"
 { $code
     "FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
     "FUNCTION: void glHint GLenum target GLenum mode ;"
-} } ;
+}
+"To make a Factor word with a name different from the C function, use " { $link POSTPONE: FUNCTION-ALIAS: } "." } ;
+
+HELP: FUNCTION-ALIAS:
+{ $syntax "FUNCTION-ALIAS: factor-name
+    return c_name ( parameters ) ;" }
+{ $values { "factor-name" "a Factor word name" } { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
+{ $description "Defines a new word " { $snippet "factor-name" } " which calls the C library function named " { $snippet "c_name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
+$nl
+"The new word must be compiled before being executed." }
+{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted. They serve no purpose other than to make the declaration easier to read." } ;
+
+{ POSTPONE: FUNCTION: POSTPONE: FUNCTION-ALIAS: } related-words
 
 HELP: TYPEDEF:
 { $syntax "TYPEDEF: old new" }
 { $values { "old" "a C type" } { "new" "a C type" } }
-{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
+{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
 HELP: C-ENUM:
-{ $syntax "C-ENUM: words... ;" }
+{ $syntax "C-ENUM: type/f words... ;" }
-{ $values { "words" "a sequence of word names" } }
+{ $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
-{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
+{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to the rules of C enums." }
 { $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
 { $examples
     "Here is an example enumeration definition:"
-    { $code "C-ENUM: red green blue ;" }
+    { $code "C-ENUM: color_t red { green 3 } blue ;" }
     "It is equivalent to the following series of definitions:"
-    { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
+    { $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" }
 } ;
 
 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 pointer (that is, as " { $snippet "type*" } ")." $nl
+{ $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 } "."
-{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
+{ $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* } ;
 STRUCT: forward { x backward* } ; """ } }
-{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
+{ $notes "Primitive C types are displayed using " { $snippet "C-TYPE:" } " syntax when they are " { $link see } "n." } ;
 
 HELP: CALLBACK:
 { $syntax "CALLBACK: return type ( parameters ) ;" }
@@ -112,11 +124,6 @@ HELP: c-struct?
 { $values { "c-type" "a C type" } { "?" "a boolean" } }
 { $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
 
-HELP: define-function
-{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
-{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
-
 HELP: C-GLOBAL:
 { $syntax "C-GLOBAL: type name" }
 { $values { "type" "a C type" } { "name" "a C global variable name" } }

basis/alien/syntax/syntax.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types
+USING: accessors arrays alien alien.c-types alien.arrays
-alien.arrays alien.strings kernel math namespaces parser
+alien.strings kernel math namespaces parser sequences words
-sequences words quotations math.parser splitting grouping
+quotations math.parser splitting grouping effects assocs
-effects assocs combinators lexer strings.parser alien.parser 
+combinators lexer strings.parser alien.parser fry vocabs.parser
-fry vocabs.parser words.constant alien.libraries ;
+words.constant alien.libraries ;
 IN: alien.syntax
 
 SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
@@ -13,10 +13,14 @@ SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
 
 SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
 
-SYNTAX: LIBRARY: scan "c-library" set ;
+SYNTAX: LIBRARY: scan current-library set ;
 
 SYNTAX: FUNCTION:
-    (FUNCTION:) define-declared ;
+    (FUNCTION:) make-function define-declared ;
+
+SYNTAX: FUNCTION-ALIAS:
+    scan create-function
+    (FUNCTION:) (make-function) define-declared ;
 
 SYNTAX: CALLBACK:
     (CALLBACK:) define-inline ;
@@ -25,25 +29,18 @@ SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
 SYNTAX: C-ENUM:
-    ";" parse-tokens
+    scan dup "f" =
-    [ [ create-in ] dip define-constant ] each-index ;
+    [ drop ]
+    [ (CREATE-C-TYPE) dup save-location int swap typedef ] if
+    0 parse-enum-members ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;
 
-ERROR: no-such-symbol name library ;
-
-: address-of ( name library -- value )
-    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
-
 SYNTAX: &:
-    scan "c-library" get '[ _ _ address-of ] append! ;
+    scan current-library get '[ _ _ address-of ] append! ;
-
-: global-quot ( type word -- quot )
-    name>> "c-library" get '[ _ _ address-of 0 ]
-    swap c-type-getter-boxer append ;
-
-: define-global ( type word -- )
-    [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
 
 SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
+
+SYNTAX: pointer:
+    scan-c-type <pointer> suffix! ;

basis/base64/base64.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators io io.binary io.encodings.binary
 io.streams.byte-array kernel math namespaces
-sequences strings io.crlf ;
+sequences strings ;
 IN: base64
 
 ERROR: malformed-base64 ;
@@ -35,7 +35,7 @@ SYMBOL: column
 : write1-lines ( ch -- )
     write1
     column get [
-        1 + [ 76 = [ crlf ] when ]
+        1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ]
         [ 76 mod column set ] bi
     ] when* ;
 

basis/binary-search/binary-search.factor

@@ -21,7 +21,7 @@ DEFER: (search)
 : keep-searching ( seq quot -- slice )
     [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
 
-: (search) ( quot: ( elt -- <=> ) seq -- i elt )
+: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
     dup length 1 <= [
         finish
     ] [

basis/bit-arrays/bit-arrays.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data accessors math alien.accessors kernel
+USING: alien alien.data accessors math alien.accessors kernel
 kernel.private sequences sequences.private byte-arrays
 parser prettyprint.custom fry ;
 IN: bit-arrays

basis/bit-sets/bit-sets-docs.factor

@@ -0,0 +1,18 @@
+USING: help.markup help.syntax sequences math ;
+IN: bit-sets
+
+ARTICLE: "bit-sets" "Bit sets"
+"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl
+"Bit sets form a class:"
+{ $subsection bit-set }
+"Constructing new bit sets:"
+{ $subsection <bit-set> } ;
+
+ABOUT: "bit-sets"
+
+HELP: bit-set
+{ $class-description "The class of bit-array-based " { $link "sets" } "." } ;
+
+HELP: <bit-set>
+{ $values { "capacity" integer } { "bit-set" bit-set } }
+{ $description "Creates a new bit set with the given capacity. This set is initially empty and can contain as members integers between 0 and " { $snippet "capacity" } "-1." } ;

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

@@ -1,17 +1,63 @@
-USING: bit-sets tools.test bit-arrays ;
+USING: bit-sets tools.test sets kernel bit-arrays ;
 IN: bit-sets.tests
 
-[ ?{ t f t f t f } ] [
+[ T{ bit-set f ?{ t f t f t f } } ] [
-    ?{ t f f f t f }
+    T{ bit-set f ?{ t f f f t f } }
-    ?{ f f t f t f } bit-set-union
+    T{ bit-set f ?{ f f t f t f } } union
 ] unit-test
 
-[ ?{ f f f f t f } ] [
+[ T{ bit-set f ?{ f f f f t f } } ] [
-    ?{ t f f f t f }
+    T{ bit-set f ?{ t f f f t f } }
-    ?{ f f t f t f } bit-set-intersect
+    T{ bit-set f ?{ f f t f t f } } intersect
 ] unit-test
 
-[ ?{ t f t f f f } ] [
+[ T{ bit-set f ?{ t f t f f f } } ] [
-    ?{ t t t f f f }
+    T{ bit-set f ?{ t t t f f f } }
-    ?{ f t f f t t } bit-set-diff
+    T{ bit-set f ?{ f t f f t t } } diff
 ] unit-test
+
+[ f ] [
+    T{ bit-set f ?{ t t t f f f } }
+    T{ bit-set f ?{ f t f f t t } } subset?
+] unit-test
+
+[ t ] [
+    T{ bit-set f ?{ t t t f f f } }
+    T{ bit-set f ?{ f t f f f f } } subset?
+] unit-test
+
+[ t ] [
+    { 0 1 2 }
+    T{ bit-set f ?{ f t f f f f } } subset?
+] unit-test
+
+[ f ] [
+    T{ bit-set f ?{ f t f f f f } }
+    T{ bit-set f ?{ t t t f f f } } subset?
+] unit-test
+
+[ f ] [
+    { 1 }
+    T{ bit-set f ?{ t t t f f f } } subset?
+] unit-test
+
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
+
+[ t V{ 1 2 3 } ] [
+    { 1 2 } 5 <bit-set> set-like
+    [ bit-set? ] keep
+    3 over adjoin
+    members
+] unit-test
+
+[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
+[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
+[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
+
+[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
+
+[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
+[ 1 <bit-set> dup clone 0 over adjoin ] unit-test

basis/bit-sets/bit-sets.factor

@@ -1,10 +1,40 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
 IN: bit-sets
 
+TUPLE: bit-set { table bit-array read-only } ;
+
+: <bit-set> ( capacity -- bit-set )
+    <bit-array> bit-set boa ;
+
+INSTANCE: bit-set set
+
+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
+    [ t ] 2dip table>> set-nth ;
+
+M: bit-set delete
+    ! This isn't allowed to crash 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
+! that the other thing can also be represented as a bitset
+! of the same length.
 <PRIVATE
 
+ERROR: check-bit-set-failed ;
+
+: check-bit-set ( bit-set -- bit-set )
+    dup bit-set? [ check-bit-set-failed ] unless ; inline
+
 : bit-set-map ( seq1 seq2 quot -- seq )
     [ 2drop length>> ]
     [
@@ -14,18 +44,43 @@ IN: bit-sets
         ] dip 2map
     ] 3bi bit-array boa ; inline
 
+: (bit-set-op) ( set1 set2 -- table1 table2 )
+    [ set-like ] keep [ table>> ] bi@ ; inline
+
+: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
+    [ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
+
 PRIVATE>
 
-: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+M: bit-set union
+    [ bitor ] bit-set-op ;
 
-HINTS: bit-set-union bit-array bit-array ;
+M: bit-set intersect
+    [ bitand ] bit-set-op ;
 
-: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+M: bit-set diff
+    [ bitnot bitand ] bit-set-op ;
 
-HINTS: bit-set-intersect bit-array bit-array ;
+M: bit-set subset?
+    [ intersect ] keep = ;
 
-: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+M: bit-set members
+    [ table>> length iota ] keep [ in? ] curry filter ;
 
-HINTS: bit-set-diff bit-array bit-array ;
+<PRIVATE
 
-: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
+: bit-set-like ( set bit-set -- bit-set' )
+    ! This crashes if there are keys that can't be put in the bit set
+    over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
+    [ drop ] [
+        [ members ] dip table>> length <bit-set>
+        [ [ adjoin ] curry each ] keep
+    ] if ;
+
+PRIVATE>
+
+M: bit-set set-like
+    bit-set-like check-bit-set ; inline
+
+M: bit-set clone
+    table>> clone bit-set boa ;

basis/bootstrap/compiler/compiler.factor

@@ -20,10 +20,8 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"prettyprint" vocab [
+"prettyprint" "alien.prettyprint" require-when
-    "stack-checker.errors.prettyprint" require
+"debugger" "alien.debugger" require-when
-    "alien.prettyprint" require
-] when
 
 "cpu." cpu name>> append require
 

basis/bootstrap/compiler/timing/tags.txt

@@ -1 +1 @@
-unportable
+not loaded

basis/bootstrap/handbook/handbook.factor

@@ -1,4 +1,4 @@
 USING: vocabs.loader vocabs kernel ;
 IN: bootstrap.handbook
 
-"bootstrap.help" vocab [ "help.handbook" require ] when
+"bootstrap.help" "help.handbook" require-when

basis/bootstrap/image/image.factor

@@ -15,10 +15,11 @@ generalizations ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
+    [ dup "winnt" = "winnt" "unix" ? ] dip
     {
-        { "ppc" [ "-ppc" append ] }
+        { "ppc" [ drop "-ppc" append ] }
-        { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        { "x86.32" [ nip "-x86.32" append ] }
-        [ nip ]
+        { "x86.64" [ nip "-x86.64" append ] }
     } case ;
 
 : my-arch ( -- arch )
@@ -32,7 +33,7 @@ IN: bootstrap.image
 
 : images ( -- seq )
     {
-        "x86.32"
+        "winnt-x86.32" "unix-x86.32"
         "winnt-x86.64" "unix-x86.64"
         "linux-ppc" "macosx-ppc"
     } ;
@@ -129,8 +130,8 @@ SYMBOL: jit-literals
 : jit-vm ( offset rc -- )
     [ jit-parameter ] dip rt-vm jit-rel ;
 
-: jit-dlsym ( name library rc -- )
+: jit-dlsym ( name rc -- )
-    rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
+    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

basis/bootstrap/threads/threads.factor

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

basis/bootstrap/ui/tools/tools.factor

@@ -4,9 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ;
 [ "bootstrap." prepend vocab ] all? [
     "ui.tools" require
 
-    "ui.backend.cocoa" vocab [
+    "ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
-        "ui.backend.cocoa.tools" require
-    ] when
 
     "ui.tools.walker" require
 ] when

basis/boxes/boxes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors ;
 IN: boxes
@@ -11,16 +11,18 @@ ERROR: box-full box ;
 
 : >box ( value box -- )
     dup occupied>>
-    [ box-full ] [ t >>occupied (>>value) ] if ;
+    [ box-full ] [ t >>occupied (>>value) ] if ; inline
 
 ERROR: box-empty box ;
 
+: check-box ( box -- box )
+    dup occupied>> [ box-empty ] unless ; inline
+
 : box> ( box -- value )
-    dup occupied>>
+    check-box [ f ] change-value f >>occupied drop ; inline
-    [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
 
 : ?box ( box -- value/f ? )
-    dup occupied>> [ box> t ] [ drop f f ] if ;
+    dup occupied>> [ box> t ] [ drop f f ] if ; inline
 
 : if-box? ( box quot -- )
     [ ?box ] dip [ drop ] if ; inline

basis/cairo/ffi/ffi.factor

@@ -1,6 +1,8 @@
 ! Copyright (c) 2007 Sampo Vuori
 ! Copyright (c) 2008 Matthew Willis
 !
+
+
 ! Adapted from cairo.h, version 1.5.14
 ! License: http://factorcode.org/license.txt
 
@@ -10,15 +12,15 @@ alien.libraries classes.struct ;
 
 IN: cairo.ffi
 << {
-    { [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
+    { [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
-    { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
+    { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] }
     { [ os unix? ] [ ] }
 } cond >>
 
 LIBRARY: cairo
 
 FUNCTION: int cairo_version ( ) ;
-FUNCTION: char* cairo_version_string ( ) ;
+FUNCTION: c-string cairo_version_string ( ) ;
 
 TYPEDEF: int cairo_bool_t
 
@@ -38,14 +40,13 @@ TYPEDEF: void* cairo_pattern_t
 
 TYPEDEF: void* cairo_destroy_func_t
 : cairo-destroy-func ( quot -- callback )
-    [ void { void* } "cdecl" ] dip alien-callback ; inline
+    [ void { pointer: void } cdecl ] dip alien-callback ; inline
 
 ! See cairo.h for details
 STRUCT: cairo_user_data_key_t
     { unused int } ;
 
-TYPEDEF: int cairo_status_t
+C-ENUM: cairo_status_t
-C-ENUM:
     CAIRO_STATUS_SUCCESS
     CAIRO_STATUS_NO_MEMORY
     CAIRO_STATUS_INVALID_RESTORE
@@ -79,11 +80,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
 
 TYPEDEF: void* cairo_write_func_t
 : cairo-write-func ( quot -- callback )
-    [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
+    [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
                           
 TYPEDEF: void* cairo_read_func_t
 : cairo-read-func ( quot -- callback )
-    [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
+    [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
 
 ! Functions for manipulating state objects
 FUNCTION: cairo_t*
@@ -125,8 +126,7 @@ FUNCTION: void
 cairo_pop_group_to_source ( cairo_t* cr ) ;
 
 ! Modify state
-TYPEDEF: int cairo_operator_t
+C-ENUM: cairo_operator_t
-C-ENUM:
     CAIRO_OPERATOR_CLEAR
 
     CAIRO_OPERATOR_SOURCE
@@ -163,8 +163,7 @@ cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, doub
 FUNCTION: void
 cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
 
-TYPEDEF: int cairo_antialias_t
+C-ENUM: cairo_antialias_t
-C-ENUM:
     CAIRO_ANTIALIAS_DEFAULT
     CAIRO_ANTIALIAS_NONE
     CAIRO_ANTIALIAS_GRAY
@@ -173,8 +172,7 @@ C-ENUM:
 FUNCTION: void
 cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
 
-TYPEDEF: int cairo_fill_rule_t
+C-ENUM: cairo_fill_rule_t
-C-ENUM:
     CAIRO_FILL_RULE_WINDING
     CAIRO_FILL_RULE_EVEN_ODD ;
 
@@ -184,8 +182,7 @@ cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
 FUNCTION: void
 cairo_set_line_width ( cairo_t* cr, double width ) ;
 
-TYPEDEF: int cairo_line_cap_t
+C-ENUM: cairo_line_cap_t
-C-ENUM:
     CAIRO_LINE_CAP_BUTT
     CAIRO_LINE_CAP_ROUND
     CAIRO_LINE_CAP_SQUARE ;
@@ -193,8 +190,7 @@ C-ENUM:
 FUNCTION: void
 cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
 
-TYPEDEF: int cairo_line_join_t
+C-ENUM: cairo_line_join_t
-C-ENUM:
     CAIRO_LINE_JOIN_MITER
     CAIRO_LINE_JOIN_ROUND
     CAIRO_LINE_JOIN_BEVEL ;
@@ -379,35 +375,30 @@ STRUCT: cairo_font_extents_t
     { max_x_advance double }
     { max_y_advance double } ;
 
-TYPEDEF: int cairo_font_slant_t
+C-ENUM: cairo_font_slant_t
-C-ENUM:
     CAIRO_FONT_SLANT_NORMAL
     CAIRO_FONT_SLANT_ITALIC
     CAIRO_FONT_SLANT_OBLIQUE ;
 
-TYPEDEF: int cairo_font_weight_t
+C-ENUM: cairo_font_weight_t
-C-ENUM:
     CAIRO_FONT_WEIGHT_NORMAL
     CAIRO_FONT_WEIGHT_BOLD ;
 
-TYPEDEF: int cairo_subpixel_order_t
+C-ENUM: cairo_subpixel_order_t
-C-ENUM:
     CAIRO_SUBPIXEL_ORDER_DEFAULT
     CAIRO_SUBPIXEL_ORDER_RGB
     CAIRO_SUBPIXEL_ORDER_BGR
     CAIRO_SUBPIXEL_ORDER_VRGB
     CAIRO_SUBPIXEL_ORDER_VBGR ;
 
-TYPEDEF: int cairo_hint_style_t
+C-ENUM: cairo_hint_style_t
-C-ENUM:
     CAIRO_HINT_STYLE_DEFAULT
     CAIRO_HINT_STYLE_NONE
     CAIRO_HINT_STYLE_SLIGHT
     CAIRO_HINT_STYLE_MEDIUM
     CAIRO_HINT_STYLE_FULL ;
 
-TYPEDEF: int cairo_hint_metrics_t
+C-ENUM: cairo_hint_metrics_t
-C-ENUM:
     CAIRO_HINT_METRICS_DEFAULT
     CAIRO_HINT_METRICS_OFF
     CAIRO_HINT_METRICS_ON ;
@@ -463,7 +454,7 @@ cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
 !  font object inside the the cairo_t.
 
 FUNCTION: void
-cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
+cairo_select_font_face ( cairo_t* cr, c-string family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
 
 FUNCTION: void
 cairo_set_font_size ( cairo_t* cr, double size ) ;
@@ -493,19 +484,19 @@ FUNCTION: cairo_scaled_font_t*
 cairo_get_scaled_font ( cairo_t* cr ) ;
 
 FUNCTION: void
-cairo_show_text ( cairo_t* cr, char* utf8 ) ;
+cairo_show_text ( cairo_t* cr, c-string utf8 ) ;
 
 FUNCTION: void
 cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
 
 FUNCTION: void
-cairo_text_path  ( cairo_t* cr, char* utf8 ) ;
+cairo_text_path  ( cairo_t* cr, c-string utf8 ) ;
 
 FUNCTION: void
 cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
 
 FUNCTION: void
-cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
+cairo_text_extents ( cairo_t* cr, c-string utf8, cairo_text_extents_t* extents ) ;
 
 FUNCTION: void
 cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
@@ -527,8 +518,7 @@ cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
 FUNCTION: cairo_status_t
 cairo_font_face_status ( cairo_font_face_t* font_face ) ;
 
-TYPEDEF: int cairo_font_type_t
+C-ENUM: cairo_font_type_t
-C-ENUM:
     CAIRO_FONT_TYPE_TOY
     CAIRO_FONT_TYPE_FT
     CAIRO_FONT_TYPE_WIN32
@@ -573,7 +563,7 @@ FUNCTION: void
 cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
 
 FUNCTION: void
-cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
+cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, c-string utf8, cairo_text_extents_t* extents ) ;
 
 FUNCTION: void
 cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
@@ -640,8 +630,7 @@ cairo_get_target ( cairo_t* cr ) ;
 FUNCTION: cairo_surface_t*
 cairo_get_group_target ( cairo_t* cr ) ;
 
-TYPEDEF: int cairo_path_data_type_t
+C-ENUM: cairo_path_data_type_t
-C-ENUM:
     CAIRO_PATH_MOVE_TO
     CAIRO_PATH_LINE_TO
     CAIRO_PATH_CURVE_TO
@@ -682,7 +671,7 @@ cairo_path_destroy ( cairo_path_t* path ) ;
 FUNCTION: cairo_status_t
 cairo_status ( cairo_t* cr ) ;
 
-FUNCTION: char* 
+FUNCTION: c-string 
 cairo_status_to_string ( cairo_status_t status ) ;
 
 ! Surface manipulation
@@ -707,8 +696,7 @@ cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
 FUNCTION: cairo_status_t
 cairo_surface_status ( cairo_surface_t* surface ) ;
 
-TYPEDEF: int cairo_surface_type_t
+C-ENUM: cairo_surface_type_t
-C-ENUM:
     CAIRO_SURFACE_TYPE_IMAGE
     CAIRO_SURFACE_TYPE_PDF
     CAIRO_SURFACE_TYPE_PS
@@ -731,7 +719,7 @@ FUNCTION: cairo_content_t
 cairo_surface_get_content ( cairo_surface_t* surface ) ;
 
 FUNCTION: cairo_status_t
-cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+cairo_surface_write_to_png ( cairo_surface_t* surface, c-string filename ) ;
 
 FUNCTION: cairo_status_t
 cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
@@ -771,8 +759,7 @@ cairo_surface_show_page ( cairo_surface_t* surface ) ;
 
 ! Image-surface functions
 
-TYPEDEF: int cairo_format_t
+C-ENUM: cairo_format_t
-C-ENUM:
     CAIRO_FORMAT_ARGB32
     CAIRO_FORMAT_RGB24
     CAIRO_FORMAT_A8
@@ -786,7 +773,7 @@ FUNCTION: int
 cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
 
 FUNCTION: cairo_surface_t*
-cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
+cairo_image_surface_create_for_data ( char* data, cairo_format_t format, int width, int height, int stride ) ;
 
 FUNCTION: uchar*
 cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
@@ -804,7 +791,7 @@ FUNCTION: int
 cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
 
 FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png ( char* filename ) ;
+cairo_image_surface_create_from_png ( c-string filename ) ;
 
 FUNCTION: cairo_surface_t*
 cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
@@ -844,8 +831,7 @@ cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* k
 FUNCTION: cairo_status_t
 cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
 
-TYPEDEF: int cairo_pattern_type_t
+C-ENUM: cairo_pattern_type_t
-C-ENUM:
     CAIRO_PATTERN_TYPE_SOLID
     CAIRO_PATTERN_TYPE_SURFACE
     CAIRO_PATTERN_TYPE_LINEAR
@@ -866,8 +852,7 @@ cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
 FUNCTION: void
 cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
 
-TYPEDEF: int cairo_extend_t
+C-ENUM: cairo_extend_t
-C-ENUM:
     CAIRO_EXTEND_NONE
     CAIRO_EXTEND_REPEAT
     CAIRO_EXTEND_REFLECT
@@ -879,8 +864,7 @@ cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
 FUNCTION: cairo_extend_t
 cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
 
-TYPEDEF: int cairo_filter_t
+C-ENUM: cairo_filter_t
-C-ENUM:
     CAIRO_FILTER_FAST
     CAIRO_FILTER_GOOD
     CAIRO_FILTER_BEST

basis/calendar/calendar-docs.factor

@@ -76,27 +76,27 @@ HELP: day-abbreviation3
 } related-words
 
 HELP: average-month
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
 
 HELP: months-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
 { $description "Returns the number of months in a year." } ;
 
 HELP: days-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
 
 HELP: hours-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
 
 HELP: minutes-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
 
 HELP: seconds-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
 { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
 
 HELP: julian-day-number
@@ -309,7 +309,7 @@ HELP: time-
 } ;
 
 HELP: convert-timezone
-{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp'" timestamp } }
 { $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
 { $examples
     { $example "USING: accessors calendar prettyprint ;"
@@ -319,7 +319,7 @@ HELP: convert-timezone
 } ;
 
 HELP: >local-time
-{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
 { $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
 { $examples
     { $example "USING: accessors calendar kernel prettyprint ;"
@@ -329,7 +329,7 @@ HELP: >local-time
 } ;
 
 HELP: >gmt
-{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
 { $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
 { $examples
     { $example "USING: accessors calendar kernel prettyprint ;"

basis/calendar/calendar-tests.factor

@@ -176,3 +176,13 @@ IN: calendar.tests
 [ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
 
 [ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
+
+[ t ] [
+    2009 1 29 <date> 1 months time+
+    2009 3 1 <date> =
+] unit-test
+
+[ t ] [
+    2008 1 29 <date> 1 months time+
+    2008 2 29 <date> =
+] unit-test

basis/calendar/calendar.factor

@@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3
 : day-abbreviation3 ( n -- string )
     day-abbreviations3 nth ; inline
 
-: average-month ( -- ratio ) 30+5/12 ; inline
+CONSTANT: average-month 30+5/12
-: months-per-year ( -- integer ) 12 ; inline
+CONSTANT: months-per-year 12
-: days-per-year ( -- ratio ) 3652425/10000 ; inline
+CONSTANT: days-per-year 3652425/10000
-: hours-per-year ( -- ratio ) 876582/100 ; inline
+CONSTANT: hours-per-year 876582/100
-: minutes-per-year ( -- ratio ) 5259492/10 ; inline
+CONSTANT: minutes-per-year 5259492/10
-: seconds-per-year ( -- integer ) 31556952 ; inline
+CONSTANT: seconds-per-year 31556952
 
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
@@ -170,18 +170,6 @@ M: timestamp easter ( timestamp -- timestamp )
 : microseconds ( x -- duration ) 1000000 / seconds ;
 : nanoseconds ( x -- duration ) 1000000000 / seconds ;
 
-GENERIC: year ( obj -- n )
-M: integer year ;
-M: timestamp year year>> ;
-
-GENERIC: month ( obj -- n )
-M: integer month ;
-M: timestamp month month>> ;
-
-GENERIC: day ( obj -- n )
-M: integer day ;
-M: timestamp day day>> ;
-
 GENERIC: leap-year? ( obj -- ? )
 
 M: integer leap-year? ( year -- ? )
@@ -212,7 +200,7 @@ GENERIC: +second ( timestamp x -- timestamp )
     [ 3 >>month 1 >>day ] when ;
 
 M: integer +year ( timestamp n -- timestamp )
-    [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
+    [ + ] curry change-year adjust-leap-year ;
 
 M: real +year ( timestamp n -- timestamp )
     [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
@@ -316,15 +304,15 @@ M: duration <=> [ duration>years ] compare ;
 
 GENERIC: time- ( time1 time2 -- time3 )
 
-: convert-timezone ( timestamp duration -- timestamp )
+: convert-timezone ( timestamp duration -- timestamp' )
     over gmt-offset>> over = [ drop ] [
         [ over gmt-offset>> time- time+ ] keep >>gmt-offset
     ] if ;
 
-: >local-time ( timestamp -- timestamp )
+: >local-time ( timestamp -- timestamp' )
     gmt-offset-duration convert-timezone ;
 
-: >gmt ( timestamp -- timestamp )
+: >gmt ( timestamp -- timestamp' )
     instant convert-timezone ;
 
 M: timestamp <=> ( ts1 ts2 -- n )

basis/calendar/format/format.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order math.parser math.functions kernel
+USING: accessors arrays calendar calendar.format.macros
-sequences io accessors arrays io.streams.string splitting
+combinators io io.streams.string kernel math math.functions
-combinators calendar calendar.format.macros present ;
+math.order math.parser present sequences typed ;
 IN: calendar.format
 
 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
@@ -272,16 +272,16 @@ ERROR: invalid-timestamp-format ;
 : (timestamp>ymd) ( timestamp -- )
     { YYYY "-" MM "-" DD } formatted ;
 
-: timestamp>ymd ( timestamp -- str )
+TYPED: timestamp>ymd ( timestamp: timestamp -- str )
     [ (timestamp>ymd) ] with-string-writer ;
 
 : (timestamp>hms) ( timestamp -- )
     { hh ":" mm ":" ss } formatted ;
 
-: timestamp>hms ( timestamp -- str )
+TYPED: timestamp>hms ( timestamp: timestamp -- str )
     [ (timestamp>hms) ] with-string-writer ;
 
-: timestamp>ymdhms ( timestamp -- str )
+TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
     [
         >gmt
         { (timestamp>ymd) " " (timestamp>hms) } formatted

basis/calendar/unix/platforms.txt

@@ -0,0 +1 @@
+unix

basis/calendar/unix/tags.txt

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

basis/calendar/unix/unix.factor

@@ -21,7 +21,7 @@ IN: calendar.unix
     timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
-    f time <time_t> localtime tm memory>struct ;
+    f time <time_t> localtime ;
 
 : timezone-name ( -- string )
     get-time zone>> ;

basis/calendar/windows/platforms.txt

@@ -0,0 +1 @@
+windows

basis/calendar/windows/tags.txt

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

basis/channels/channels.factor

@@ -17,7 +17,7 @@ GENERIC: from ( channel -- value )
 <PRIVATE
 
 : wait ( channel -- )
-    [ senders>> push ] curry
+    [ self ] dip senders>> push
     "channel send" suspend drop ;
 
 : (to) ( value receivers -- )
@@ -36,7 +36,7 @@ M: channel to ( value channel -- )
     [ dup wait to ] [ nip (to) ] if-empty ;
 
 M: channel from ( channel -- value )
-    [
+    [ self ] dip
-        notify senders>>
+    notify senders>>
-        [ (from) ] unless-empty
+    [ (from) ] unless-empty
-    ] curry "channel receive" suspend ;
+    "channel receive" suspend ;

basis/circular/circular.factor

@@ -64,7 +64,7 @@ TUPLE: circular-iterator
 
 <PRIVATE
 
-: (circular-while) ( iterator quot: ( obj -- ? ) -- )
+: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
     [ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
     rot [ [ dup n>> >>last-start ] dip ] when
     over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
@@ -75,5 +75,5 @@ TUPLE: circular-iterator
 
 PRIVATE>
 
-: circular-while ( circular quot: ( obj -- ? ) -- )
+: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
     [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

basis/classes/struct/struct-docs.factor

@@ -159,7 +159,7 @@ $nl
 "A C function which returns a struct by value:"
 { $code
     "USING: alien.syntax ;"
-    "FUNCTION: Point give_me_a_point ( char* description ) ;"
+    "FUNCTION: Point give_me_a_point ( c-string description ) ;"
 }
 "A C function which takes a struct parameter by reference:"
 { $code

basis/classes/struct/struct-tests.factor

@@ -1,12 +1,14 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data ascii
+USING: accessors alien alien.c-types alien.data alien.syntax ascii
-assocs byte-arrays classes.struct classes.tuple.private
+assocs byte-arrays classes.struct classes.tuple.parser
-combinators compiler.tree.debugger compiler.units destructors
+classes.tuple.private classes.tuple combinators compiler.tree.debugger
-io.encodings.utf8 io.pathnames io.streams.string kernel libc
+compiler.units destructors io.encodings.utf8 io.pathnames
-literals math mirrors namespaces prettyprint
+io.streams.string kernel libc literals math mirrors namespaces
-prettyprint.config see sequences specialized-arrays system
+prettyprint prettyprint.config see sequences specialized-arrays
-tools.test parser lexer eval layouts ;
+system tools.test parser lexer eval layouts generic.single classes
+vocabs ;
 FROM: math => float ;
+FROM: specialized-arrays.private => specialized-array-vocab ;
 QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAY: char
 SPECIALIZED-ARRAY: int
@@ -139,7 +141,7 @@ UNION-STRUCT: struct-test-float-and-bits
 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 
 STRUCT: struct-test-string-ptr
-    { x char* } ;
+    { x c-string } ;
 
 [ "hello world" ] [
     [
@@ -219,7 +221,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { type bool }
         { class object }
     }
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
+} ] [ struct-test-foo c-type fields>> ] unit-test
 
 [ {
     T{ struct-slot-spec
@@ -236,7 +238,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { class integer }
         { initial 0 }
     }
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
 
 STRUCT: struct-test-equality-1
     { x int } ;
@@ -303,6 +305,12 @@ SPECIALIZED-ARRAY: struct-test-optimization
     { x>> } inlined?
 ] unit-test
 
+[ ] [
+    [
+        struct-test-optimization specialized-array-vocab forget-vocab
+    ] with-compilation-unit
+] unit-test
+
 ! Test cloning structs
 STRUCT: clone-test-struct { x int } { y char[3] } ;
 
@@ -334,24 +342,40 @@ STRUCT: struct-that's-a-word { x int } ;
     "struct-class-test-1" parse-stream
 ] [ error>> error>> unexpected-eof? ] must-fail-with
 
+[
+    "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
+] [ error>> duplicate-slot-names? ] must-fail-with
+
+[
+    "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
+] [ error>> duplicate-slot-names? ] must-fail-with
+
 ! S{ with non-struct type
 [
     "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
     eval( -- value )
-] must-fail
+] [ error>> no-method? ] must-fail-with
 
 ! Subclassing a struct class should not be allowed
 [
-    "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+    "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
     eval( -- )
-] must-fail
+] [ error>> bad-superclass? ] must-fail-with
 
-! Remove c-type when struct class is forgotten
+! Changing a superclass into a struct should reset the subclass
-[ ] [
+TUPLE: will-become-struct ;
-    "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
-] unit-test
 
-[ f ] [ "a-struct" c-types get key? ] unit-test
+TUPLE: a-subclass < will-become-struct ;
+
+[ f ] [ will-become-struct struct-class? ] unit-test
+
+[ will-become-struct ] [ a-subclass superclass ] unit-test
+
+[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
+
+[ t ] [ will-become-struct struct-class? ] unit-test
+
+[ tuple ] [ a-subclass superclass ] unit-test
 
 STRUCT: bit-field-test
     { a uint bits: 12 }
@@ -366,6 +390,63 @@ STRUCT: bit-field-test
 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 [ 3 ] [ bit-field-test heap-size ] unit-test
 
+STRUCT: referent
+    { y int } ;
+STRUCT: referrer
+    { x referent* } ;
+
+[ 57 ] [
+    [
+        referrer <struct>
+            referent malloc-struct &free
+                57 >>y
+            >>x
+        x>> y>>
+    ] with-destructors
+] unit-test
+
+STRUCT: self-referent
+    { x self-referent* }
+    { y int } ;
+
+[ 75 ] [
+    [
+        self-referent <struct>
+            self-referent malloc-struct &free
+                75 >>y
+            >>x
+        x>> y>>
+    ] with-destructors
+] unit-test
+
+C-TYPE: forward-referent
+STRUCT: backward-referent
+    { x forward-referent* }
+    { y int } ;
+STRUCT: forward-referent
+    { x backward-referent* }
+    { y int } ;
+
+[ 41 ] [
+    [
+        forward-referent <struct>
+            backward-referent malloc-struct &free
+                41 >>y
+            >>x
+        x>> y>>
+    ] with-destructors
+] unit-test
+
+[ 14 ] [
+    [
+        backward-referent <struct>
+            forward-referent malloc-struct &free
+                14 >>y
+            >>x
+        x>> y>>
+    ] with-destructors
+] unit-test
+
 cpu ppc? [
     STRUCT: ppc-align-test-1
         { x longlong }

basis/classes/struct/struct.factor

@@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
 locals macros make math math.order parser quotations sequences
 slots slots.private specialized-arrays vectors words summary
 namespaces assocs vocabs.parser math.functions
-classes.struct.bit-accessors bit-arrays ;
+classes.struct.bit-accessors bit-arrays
+stack-checker.dependencies ;
 QUALIFIED: math
 IN: classes.struct
 
@@ -32,8 +33,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
 PREDICATE: struct-class < tuple-class
     superclass \ struct eq? ;
 
-M: struct-class valid-superclass? drop f ;
-
 SLOT: fields
 
 : struct-slots ( struct-class -- slots )
@@ -47,11 +46,11 @@ M: struct >c-ptr
 M: struct equal?
     {
         [ [ class ] bi@ = ]
-        [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
+        [ [ >c-ptr ] [ binary-object ] bi* memory= ]
     } 2&& ; inline
 
 M: struct hashcode*
-    [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline    
+    binary-object <direct-uchar-array> hashcode* ; inline
 
 : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
 
@@ -126,6 +125,14 @@ M: struct-bit-slot-spec (writer-quot)
 
 : (unboxer-quot) ( class -- quot )
     drop [ >c-ptr ] ;
+
+MACRO: read-struct-slot ( slot -- )
+    dup type>> depends-on-c-type
+    (reader-quot) ;
+
+MACRO: write-struct-slot ( slot -- )
+    dup type>> depends-on-c-type
+    (writer-quot) ;
 PRIVATE>
 
 M: struct-class boa>object
@@ -140,10 +147,11 @@ M: struct-class initial-value* <struct> ; inline
 GENERIC: struct-slot-values ( struct -- sequence )
 
 M: struct-class reader-quot
-    nip (reader-quot) ;
+    dup type>> array? [ dup type>> first define-array-vocab drop ] when
+    nip '[ _ read-struct-slot ] ;
 
 M: struct-class writer-quot
-    nip (writer-quot) ;
+    nip '[ _ write-struct-slot ] ;
 
 : offset-of ( field struct -- offset )
     struct-slots slot-named offset>> ; inline
@@ -195,7 +203,7 @@ M: struct-c-type c-struct? drop t ;
     define-inline-method ;
 
 : clone-underlying ( struct -- byte-array )
-    [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
+    binary-object memory>byte-array ; inline
 
 : (define-clone-method) ( class -- )
     [ \ clone ]
@@ -273,7 +281,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ;
     [ type>> c-type drop ] each ;
 
 : redefine-struct-tuple-class ( class -- )
-    [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+    [ struct f define-tuple-class ] [ make-final ] bi ;
 
 :: (define-struct-class) ( class slots offsets-quot -- )
     slots empty? [ struct-must-have-slots ] when
@@ -298,9 +306,6 @@ PRIVATE>
 : define-union-struct-class ( class slots -- )
     [ compute-union-offsets ] (define-struct-class) ;
 
-M: struct-class reset-class
-    [ call-next-method ] [ name>> c-types get delete-at ] bi ;
-
 ERROR: invalid-struct-slot token ;
 
 : struct-slot-class ( c-type -- class' )
@@ -358,7 +363,8 @@ PRIVATE>
     } case ;
 
 : parse-struct-definition ( -- class slots )
-    CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+    CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
+    dup [ name>> ] map check-duplicate-slots ;
 PRIVATE>
 
 SYNTAX: STRUCT:
@@ -398,4 +404,4 @@ FUNCTOR-SYNTAX: STRUCT:
 
 USING: vocabs vocabs.loader ;
 
-"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
+"prettyprint" "classes.struct.prettyprint" require-when

basis/cocoa/application/application.factor

@@ -8,7 +8,7 @@ IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
 
-C-ENUM:
+C-ENUM: f
 NSApplicationDelegateReplySuccess
 NSApplicationDelegateReplyCancel
 NSApplicationDelegateReplyFailure ;

basis/cocoa/application/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/application/tags.txt

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

basis/cocoa/callbacks/callbacks.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Kevin Reid.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces cocoa cocoa.classes
+USING: alien.c-types assocs kernel namespaces cocoa
-cocoa.subclassing debugger ;
+cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
 IN: cocoa.callbacks
 
 SYMBOL: callbacks

basis/cocoa/callbacks/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/callbacks/tags.txt

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

basis/cocoa/cocoa.factor

@@ -39,6 +39,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
 
 [
     {
+        "NSAlert"
         "NSApplication"
         "NSArray"
         "NSAutoreleasePool"

basis/cocoa/dialogs/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/dialogs/tags.txt

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

basis/cocoa/enumeration/enumeration.factor

@@ -15,7 +15,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
         @
     ] with-destructors ; inline
 
-:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
+:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
     object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
     items-count 0 = [
         state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
@@ -23,10 +23,10 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
         object quot state stackbuf count (NSFastEnumeration-each)
     ] unless ; inline recursive
 
-: NSFastEnumeration-each ( object quot -- )
+: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... )
     [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
 
-: NSFastEnumeration-map ( object quot -- vector )
+: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector )
     NS-EACH-BUFFER-SIZE <vector>
     [ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline
 

basis/cocoa/enumeration/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/enumeration/tags.txt

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

basis/cocoa/messages/messages.factor

@@ -5,8 +5,7 @@ classes.struct continuations combinators compiler compiler.alien
 core-graphics.types stack-checker kernel math namespaces make
 quotations sequences strings words cocoa.runtime cocoa.types io
 macros memoize io.encodings.utf8 effects layouts libc
-libc.private lexer init core-foundation fry generalizations
+lexer init core-foundation fry generalizations specialized-arrays ;
-specialized-arrays ;
 QUALIFIED-WITH: alien.c-types c
 IN: cocoa.messages
 
@@ -76,13 +75,13 @@ MACRO: (send) ( selector super? -- quot )
 : super-send ( receiver args... selector -- return... ) t (send) ; inline
 
 ! Runtime introspection
-SYMBOL: class-startup-hooks
+SYMBOL: class-init-hooks
 
-class-startup-hooks [ H{ } clone ] initialize
+class-init-hooks [ H{ } clone ] initialize
 
 : (objc-class) ( name word -- class )
     2dup execute dup [ 2nip ] [
-        drop over class-startup-hooks get at [ call( -- ) ] when*
+        drop over class-init-hooks get at [ call( -- ) ] when*
         2dup execute dup [ 2nip ] [
             2drop "No such class: " prepend throw
         ] if
@@ -110,7 +109,7 @@ H{
     { "d" c:double }
     { "B" c:bool }
     { "v" c:void }
-    { "*" c:char* }
+    { "*" c:c-string }
     { "?" unknown_type }
     { "@" id }
     { "#" Class }
@@ -229,16 +228,19 @@ ERROR: no-objc-type name ;
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
 : define-objc-class-word ( quot name -- )
-    [ class-startup-hooks get set-at ]
+    [ class-init-hooks get set-at ]
     [
         [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
         (( -- class )) define-declared
     ] bi ;
 
 : import-objc-class ( name quot -- )
-    over define-objc-class-word
+    2dup swap define-objc-class-word
-    [ objc-class register-objc-methods ]
+    over class-exists? [ drop ] [ call( -- ) ] if
-    [ objc-meta-class register-objc-methods ] bi ;
+    dup class-exists? [
+        [ objc_getClass register-objc-methods ]
+        [ objc_getMetaClass register-objc-methods ] bi
+    ] [ drop ] if ;
 
 : root-class ( class -- root )
     dup class_getSuperclass [ root-class ] [ ] ?if ;

basis/cocoa/messages/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/messages/tags.txt

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

basis/cocoa/nibs/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/nibs/tags.txt

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

basis/cocoa/pasteboard/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/pasteboard/tags.txt

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

basis/cocoa/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/plists/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/plists/tags.txt

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

basis/cocoa/runtime/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/runtime/runtime.factor

@@ -7,11 +7,11 @@ TYPEDEF: void* SEL
 
 TYPEDEF: void* id
 
-FUNCTION: char* sel_getName ( SEL aSelector ) ;
+FUNCTION: c-string sel_getName ( SEL aSelector ) ;
 
 FUNCTION: char sel_isMapped ( SEL aSelector ) ;
 
-FUNCTION: SEL sel_registerName ( char* str ) ;
+FUNCTION: SEL sel_registerName ( c-string str ) ;
 
 TYPEDEF: void* Class
 TYPEDEF: void* Method
@@ -33,13 +33,13 @@ CONSTANT: CLS_METHOD_ARRAY HEX: 100
 
 FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
 
-FUNCTION: Class objc_getClass ( char* class ) ;
+FUNCTION: Class objc_getClass ( c-string class ) ;
 
-FUNCTION: Class objc_getMetaClass ( char* class ) ;
+FUNCTION: Class objc_getMetaClass ( c-string class ) ;
 
-FUNCTION: Protocol objc_getProtocol ( char* class ) ;
+FUNCTION: Protocol objc_getProtocol ( c-string class ) ;
 
-FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
+FUNCTION: Class objc_allocateClassPair ( Class superclass, c-string name, size_t extraBytes ) ;
 FUNCTION: void objc_registerClassPair ( Class cls ) ;
 
 FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
@@ -54,7 +54,7 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
 
 FUNCTION: Class class_getSuperclass ( Class cls ) ;
 
-FUNCTION: char* class_getName ( Class cls ) ;
+FUNCTION: c-string class_getName ( Class cls ) ;
 
 FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
 
@@ -64,7 +64,7 @@ FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
 
 FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
 
-FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
+FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, c-string* type, int* offset ) ;
 
 FUNCTION: void* method_copyReturnType ( Method method ) ;
 

basis/cocoa/runtime/tags.txt

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

basis/cocoa/subclassing/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/subclassing/subclassing.factor

@@ -40,7 +40,7 @@ IN: cocoa.subclassing
 
 : prepare-method ( ret types quot -- type imp )
     [ [ encode-types ] 2keep ] dip
-    '[ _ _ "cdecl" _ alien-callback ]
+    '[ _ _ cdecl _ alien-callback ]
     (( -- callback )) define-temp ;
 
 : prepare-methods ( methods -- methods )

basis/cocoa/subclassing/tags.txt

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

basis/cocoa/tags.txt

@@ -1,2 +1,2 @@
-unportable
 bindings
+ffi

basis/cocoa/types/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/types/tags.txt

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

basis/cocoa/views/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/views/tags.txt

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

basis/cocoa/windows/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/cocoa/windows/tags.txt

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

basis/command-line/command-line-docs.factor

@@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
     { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
     { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
     { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
+    { { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
     { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
     { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
     { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
     { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+    { { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
     { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
     { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
 }
-"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
+"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
 
 ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
 "A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"

basis/compiler/alien/alien.factor

@@ -1,17 +1,17 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces make math sequences layouts
 alien.c-types cpu.architecture ;
 IN: compiler.alien
 
-: large-struct? ( ctype -- ? )
+: large-struct? ( type -- ? )
     dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
 
 : alien-parameters ( params -- seq )
     dup parameters>>
-    swap return>> large-struct? [ void* prefix ] when ;
+    swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
 
-: alien-return ( params -- ctype )
+: alien-return ( params -- type )
     return>> dup large-struct? [ drop void ] when ;
 
 : c-type-stack-align ( type -- align )

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -12,6 +12,7 @@ compiler.cfg.registers
 compiler.cfg.comparisons
 compiler.cfg.instructions
 compiler.cfg.representations.preferred ;
+FROM: namespaces => set ;
 IN: compiler.cfg.alias-analysis
 
 ! We try to eliminate redundant slot operations using some simple heuristics.
@@ -201,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# field-name>> ;
+M: ##vm-field insn-slot# offset>> ;
+M: ##set-vm-field insn-slot# offset>> ;
 
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
-M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
+M: ##vm-field insn-object drop \ ##vm-field ;
+M: ##set-vm-field insn-object drop \ ##vm-field ;
 
 : init-alias-analysis ( insns -- insns' )
     H{ } clone histories set
@@ -221,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
     0 ac-counter set
     next-ac heap-ac set
 
-    \ ##vm-field-ptr set-new-ac
+    \ ##vm-field set-new-ac
     \ ##alien-global set-new-ac
 
     dup local-live-in [ set-heap-ac ] each ;
@@ -297,14 +300,14 @@ SYMBOL: live-stores
     histories get
     values [
         values [ [ store? ] filter [ insn#>> ] map ] map concat
-    ] map concat unique
+    ] map concat fast-set
     live-stores set ;
 
 GENERIC: eliminate-dead-stores* ( insn -- insn' )
 
 : (eliminate-dead-stores) ( insn -- insn' )
     dup insn-slot# [
-        insn# get live-stores get key? [
+        insn# get live-stores get in? [
             drop f
         ] unless
     ] when ;

basis/compiler/cfg/builder/builder-tests.factor

@@ -68,8 +68,8 @@ IN: compiler.cfg.builder.tests
     [ [ dup ] loop ]
     [ [ 2 ] [ 3 throw ] if 4 ]
     [ int f "malloc" { int } alien-invoke ]
-    [ int { int } "cdecl" alien-indirect ]
+    [ int { int } cdecl alien-indirect ]
-    [ int { int } "cdecl" [ ] alien-callback ]
+    [ int { int } cdecl [ ] alien-callback ]
     [ swap - + * ]
     [ swap slot ]
     [ blahblah ]

basis/compiler/cfg/cfg.factor

@@ -39,7 +39,7 @@ predecessors-valid? dominance-valid? loops-valid? ;
 : predecessors-changed ( cfg -- cfg )
     f >>predecessors-valid? ;
 
-: with-cfg ( cfg quot: ( cfg -- ) -- )
+: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
     [ dup cfg ] dip with-variable ; inline
 
 TUPLE: mr { instructions array } word label ;

basis/compiler/cfg/dce/dce.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
+USING: accessors assocs kernel namespaces sequences
 compiler.cfg.instructions compiler.cfg.def-use
-compiler.cfg.rpo compiler.cfg.predecessors ;
+compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ;
+FROM: namespaces => set ;
 IN: compiler.cfg.dce
 
 ! Maps vregs to sequences of vregs
@@ -12,18 +13,18 @@ SYMBOL: liveness-graph
 SYMBOL: live-vregs
 
 : live-vreg? ( vreg -- ? )
-    live-vregs get key? ;
+    live-vregs get in? ;
 
 ! vregs which are the result of an allocation
 SYMBOL: allocations
 
 : allocation? ( vreg -- ? )
-    allocations get key? ;
+    allocations get in? ;
 
 : init-dead-code ( -- )
     H{ } clone liveness-graph set
-    H{ } clone live-vregs set
+    HS{ } clone live-vregs set
-    H{ } clone allocations set ;
+    HS{ } clone allocations set ;
 
 GENERIC: build-liveness-graph ( insn -- )
 
@@ -46,7 +47,7 @@ M: ##write-barrier-imm build-liveness-graph
     dup src>> setter-liveness-graph ;
 
 M: ##allot build-liveness-graph
-    [ dst>> allocations get conjoin ] [ call-next-method ] bi ;
+    [ dst>> allocations get adjoin ] [ call-next-method ] bi ;
 
 M: insn build-liveness-graph
     dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
@@ -55,8 +56,8 @@ GENERIC: compute-live-vregs ( insn -- )
 
 : (record-live) ( vregs -- )
     [
-        dup live-vregs get key? [ drop ] [
+        dup live-vreg? [ drop ] [
-            [ live-vregs get conjoin ]
+            [ live-vregs get adjoin ]
             [ liveness-graph get at (record-live) ]
             bi
         ] if

basis/compiler/cfg/def-use/def-use.factor

@@ -5,6 +5,8 @@ compiler.units fry generalizations generic kernel locals
 namespaces quotations sequences sets slots words
 compiler.cfg.instructions compiler.cfg.instructions.syntax
 compiler.cfg.rpo ;
+FROM: namespaces => set ;
+FROM: sets => members ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vreg ( insn -- vreg/f )
@@ -94,9 +96,9 @@ SYMBOLS: defs insns uses ;
     cfg [| block |
         block instructions>> [
             dup ##phi?
-            [ inputs>> [ use conjoin-at ] assoc-each ]
+            [ inputs>> [ use adjoin-at ] assoc-each ]
-            [ uses-vregs [ block swap use conjoin-at ] each ]
+            [ uses-vregs [ block swap use adjoin-at ] each ]
             if
         ] each
     ] each-basic-block
-    use [ keys ] assoc-map uses set ;
+    use [ members ] assoc-map uses set ;

basis/compiler/cfg/dominance/dominance.factor

@@ -3,6 +3,7 @@
 USING: accessors assocs combinators sets math fry kernel math.order
 dlists deques vectors namespaces sequences sorting locals
 compiler.cfg.rpo compiler.cfg.predecessors ;
+FROM: namespaces => set ;
 IN: compiler.cfg.dominance
 
 ! Reference:

basis/compiler/cfg/instructions/instructions.factor

@@ -660,9 +660,13 @@ INSN: ##alien-global
 def: dst/int-rep
 literal: symbol library ;
 
-INSN: ##vm-field-ptr
+INSN: ##vm-field
 def: dst/int-rep
-literal: field-name ;
+literal: offset ;
+
+INSN: ##set-vm-field
+use: src/int-rep
+literal: offset ;
 
 ! FFI
 INSN: ##alien-invoke
@@ -831,8 +835,8 @@ UNION: ##allocation
 ##box-displaced-alien ;
 
 ! For alias analysis
-UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
+UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
-UNION: ##write ##set-slot ##set-slot-imm ;
+UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
 ! Instructions that kill all live vregs but cannot trigger GC
 UNION: partial-sync-insn

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -30,7 +30,9 @@ IN: compiler.cfg.intrinsics
 
 {
     { kernel.private:tag [ drop emit-tag ] }
+    { kernel.private:context-object [ emit-context-object ] }
     { kernel.private:special-object [ emit-special-object ] }
+    { kernel.private:set-special-object [ emit-set-special-object ] }
     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
     { math.private:fixnum+ [ drop emit-fixnum+ ] }