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

Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib

@@ -3,15 +3,13 @@
 <plist version="1.0">
 <dict>
 	<key>IBFramework Version</key>
-	<string>629</string>
+	<string>677</string>
 	<key>IBOldestOS</key>
 	<integer>5</integer>
 	<key>IBOpenObjects</key>
-	<array>
+	<array/>
-		<integer>305</integer>
-	</array>
 	<key>IBSystem Version</key>
-	<string>9G55</string>
+	<string>9J61</string>
 	<key>targetFramework</key>
 	<string>IBCocoaFramework</string>
 </dict>

Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib

@@ -1,17 +1,32 @@
-{
+<?xml version="1.0" encoding="UTF-8"?>
-    IBClasses = (
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
-        {
+<plist version="1.0">
-            ACTIONS = {
+<dict>
-                newFactorWorkspace = id; 
+	<key>IBClasses</key>
-                runFactorFile = id; 
+	<array>
-                saveFactorImage = id; 
+		<dict>
-                saveFactorImageAs = id; 
+			<key>ACTIONS</key>
-                showFactorHelp = id; 
+			<dict>
-            }; 
+				<key>newFactorWorkspace</key>
-            CLASS = FirstResponder; 
+				<string>id</string>
-            LANGUAGE = ObjC; 
+				<key>runFactorFile</key>
-            SUPERCLASS = NSObject; 
+				<string>id</string>
-        }
+				<key>saveFactorImage</key>
-    ); 
+				<string>id</string>
-    IBVersion = 1; 
+				<key>saveFactorImageAs</key>
-}
+				<string>id</string>
+				<key>showFactorHelp</key>
+				<string>id</string>
+			</dict>
+			<key>CLASS</key>
+			<string>FirstResponder</string>
+			<key>LANGUAGE</key>
+			<string>ObjC</string>
+			<key>SUPERCLASS</key>
+			<string>NSObject</string>
+		</dict>
+	</array>
+	<key>IBVersion</key>
+	<string>1</string>
+</dict>
+</plist>

Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib

@@ -1,21 +1,18 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
 <plist version="1.0">
 <dict>
-	<key>IBDocumentLocation</key>
-	<string>1266 155 525 491 0 0 2560 1578 </string>
-	<key>IBEditorPositions</key>
-	<dict>
-		<key>29</key>
-		<string>326 905 270 44 0 0 2560 1578 </string>
-	</dict>
 	<key>IBFramework Version</key>
-	<string>439.0</string>
+	<string>677</string>
+	<key>IBOldestOS</key>
+	<integer>5</integer>
 	<key>IBOpenObjects</key>
 	<array>
-		<integer>29</integer>
+		<integer>293</integer>
 	</array>
 	<key>IBSystem Version</key>
-	<string>8R218</string>
+	<string>9J61</string>
+	<key>targetFramework</key>
+	<string>IBCocoaFramework</string>
 </dict>
 </plist>

README.txt

@@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc,
 Pango, X11, and OpenGL. On a Debian-derived Linux distribution
 (like Ubuntu), you can use the following line to grab everything:
 
-    sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
+    sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
+
+Note that if you are using a proprietary OpenGL driver, you should
+probably leave out the last package in the list.
 
 If your DISPLAY environment variable is set, the UI will start
-automatically:
+automatically when you run Factor:
 
   ./factor
 

basis/alarms/alarms-tests.factor

@@ -1,6 +1,6 @@
-IN: alarms.tests
 USING: alarms alarms.private kernel calendar sequences
 tools.test threads concurrency.count-downs ;
+IN: alarms.tests
 
 [ ] [
     1 <count-down>

basis/alarms/alarms.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators generic init
+USING: accessors assocs boxes calendar
-kernel math namespaces sequences heaps boxes threads
+combinators.short-circuit fry heaps init kernel math.order
-quotations assocs math.order ;
+namespaces quotations threads ;
 IN: alarms
 
 TUPLE: alarm
@@ -21,21 +21,21 @@ SYMBOL: alarm-thread
 
 ERROR: bad-alarm-frequency frequency ;
 : check-alarm ( frequency/f -- frequency/f )
-    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
+    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
 
 : <alarm> ( quot time frequency -- alarm )
     check-alarm <box> alarm boa ;
 
 : register-alarm ( alarm -- )
-    dup dup time>> alarms get-global heap-push*
+    [ dup time>> alarms get-global heap-push* ]
-    swap entry>> >box
+    [ entry>> >box ] bi
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
     [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup [ swap interval>> time+ now max ] change-time register-alarm ;
+    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]

basis/alien/arrays/arrays-docs.factor

@@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
 ARTICLE: "c-arrays" "C arrays"
 "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
 $nl
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+$nl
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"
+{ $subsection require-c-array }
+{ $subsection <c-array> }
+{ $subsection <c-direct-array> } ;

basis/alien/arrays/arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings alien.c-types alien.accessors alien.structs
 arrays words sequences math kernel namespaces fry libc cpu.architecture
-io.encodings.utf8 ;
+io.encodings.utf8 accessors ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -11,7 +11,12 @@ M: array c-type ;
 
 M: array c-type-class drop object ;
 
-M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
+M: array c-type-boxed-class drop object ;
+
+: array-length ( seq -- n )
+    [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
+
+M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
 
 M: array c-type-align first c-type-align ;
 
@@ -27,11 +32,15 @@ M: array box-return drop "void*" box-return ;
 
 M: array stack-size drop "void*" stack-size ;
 
-M: array c-type-boxer-quot drop [ ] ;
+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 ] ;
 
-M: value-type c-type-reg-class drop int-regs ;
+M: value-type c-type-rep drop int-rep ;
 
 M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;
@@ -45,8 +54,9 @@ PREDICATE: string-type < pair
 
 M: string-type c-type ;
 
-M: string-type c-type-class
+M: string-type c-type-class drop object ;
-    drop object ;
+
+M: string-type c-type-boxed-class drop object ;
 
 M: string-type heap-size
     drop "void*" heap-size ;
@@ -72,8 +82,8 @@ M: string-type box-return
 M: string-type stack-size
     drop "void*" stack-size ;
 
-M: string-type c-type-reg-class
+M: string-type c-type-rep
-    drop int-regs ;
+    drop int-rep ;
 
 M: string-type c-type-boxer
     drop "void*" c-type-boxer ;

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

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
 byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors ;
+io.encodings.string debugger destructors vocabs.loader ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -49,11 +49,10 @@ HELP: c-setter
 { $errors "Throws an error if the type does not exist." } ;
 
 HELP: <c-array>
-{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
+{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
-{ $errors "Throws an error if the type does not exist or the requested size is negative." } ;
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
-
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
-{ <c-array> malloc-array } related-words
 
 HELP: <c-object>
 { $values { "type" "a C type" } { "array" byte-array } }
@@ -73,9 +72,10 @@ HELP: byte-array>memory
 
 HELP: malloc-array
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
+{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ;
+{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
 
 HELP: malloc-object
 { $values { "type" "a C type" } { "alien" alien } }
@@ -89,6 +89,8 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
+{ <c-array> <c-direct-array> malloc-array } related-words
+
 HELP: box-parameter
 { $values { "n" integer } { "ctype" string } }
 { $description "Generates code for converting a C value stored at  offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
@@ -128,6 +130,16 @@ HELP: malloc-string
     }
 } ;
 
+HELP: require-c-array
+{ $values { "c-type" "a C type" } }
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence types loaded." } ;
+
+HELP: <c-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set 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 " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
 $nl

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

@@ -1,10 +1,10 @@
-IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
+IN: alien.c-types.tests
 
 CONSTANT: xyz 123
 
-[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+[ 492 ] [ { "int" xyz } heap-size ] unit-test
 
 [ -1 ] [ -1 <char> *char ] unit-test
 [ -1 ] [ -1 <short> *short ] unit-test

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

@@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
 cpu.architecture alien alien.accessors alien.strings quotations
 layouts system compiler.units io io.files io.encodings.binary
 io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -13,17 +13,24 @@ DEFER: *char
 
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
-TUPLE: c-type
+TUPLE: abstract-c-type
 { class class initial: object }
-boxer
+{ boxed-class class initial: object }
 { boxer-quot callable }
-unboxer
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-{ reg-class initial: int-regs }
 size
 align
+array-class
+array-constructor
+(array)-constructor
+direct-array-constructor ;
+
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
 stack-align? ;
 
 : <c-type> ( -- type )
@@ -68,12 +75,88 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+: ?require-word ( word/pair -- )
+    dup word? [ drop ] [ first require ] ?if ;
+
+! These words being foldable means that words need to be
+! recompiled if a C type is redefined. Even so, folding the
+! size facilitates some optimizations.
+GENERIC: heap-size ( type -- size ) foldable
+
+M: string heap-size c-type heap-size ;
+
+M: abstract-c-type heap-size size>> ;
+
+GENERIC: require-c-array ( c-type -- )
+
+M: object require-c-array
+    drop ;
+
+M: c-type require-c-array
+    array-class>> ?require-word ;
+
+M: string require-c-array
+    c-type require-c-array ;
+
+M: array require-c-array
+    first c-type require-c-array ;
+
+ERROR: specialized-array-vocab-not-loaded vocab word ;
+
+: c-array-constructor ( c-type -- word )
+    array-constructor>> dup array?
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+: c-(array)-constructor ( c-type -- word )
+    (array)-constructor>> dup array?
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+: c-direct-array-constructor ( c-type -- word )
+    direct-array-constructor>> dup array?
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+GENERIC: <c-array> ( len c-type -- array )
+M: object <c-array>
+    c-array-constructor execute( len -- array ) ; inline
+M: string <c-array>
+    c-type <c-array> ; inline
+M: array <c-array>
+    first c-type <c-array> ; inline
+
+GENERIC: (c-array) ( len c-type -- array )
+M: object (c-array)
+    c-(array)-constructor execute( len -- array ) ; inline
+M: string (c-array)
+    c-type (c-array) ; inline
+M: array (c-array)
+    first c-type (c-array) ; inline
+
+GENERIC: <c-direct-array> ( alien len c-type -- array )
+M: object <c-direct-array>
+    c-direct-array-constructor execute( alien len -- array ) ; inline
+M: string <c-direct-array>
+    c-type <c-direct-array> ; inline
+M: array <c-direct-array>
+    first c-type <c-direct-array> ; inline
+
+: malloc-array ( n type -- alien )
+    [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+
+: (malloc-array) ( n type -- alien )
+    [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+
 GENERIC: c-type-class ( name -- class )
 
-M: c-type c-type-class class>> ;
+M: abstract-c-type c-type-class class>> ;
 
 M: string c-type-class c-type c-type-class ;
 
+GENERIC: c-type-boxed-class ( name -- class )
+
+M: abstract-c-type c-type-boxed-class boxed-class>> ;
+
+M: string c-type-boxed-class c-type c-type-boxed-class ;
+
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
@@ -82,7 +165,7 @@ M: string c-type-boxer c-type c-type-boxer ;
 
 GENERIC: c-type-boxer-quot ( name -- quot )
 
-M: c-type c-type-boxer-quot boxer-quot>> ;
+M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
 M: string c-type-boxer-quot c-type c-type-boxer-quot ;
 
@@ -94,15 +177,15 @@ M: string c-type-unboxer c-type c-type-unboxer ;
 
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
-M: c-type c-type-unboxer-quot unboxer-quot>> ;
+M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 
 M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
 
-GENERIC: c-type-reg-class ( name -- reg-class )
+GENERIC: c-type-rep ( name -- rep )
 
-M: c-type c-type-reg-class reg-class>> ;
+M: c-type c-type-rep rep>> ;
 
-M: string c-type-reg-class c-type c-type-reg-class ;
+M: string c-type-rep c-type c-type-rep ;
 
 GENERIC: c-type-getter ( name -- quot )
 
@@ -118,7 +201,7 @@ M: string c-type-setter c-type c-type-setter ;
 
 GENERIC: c-type-align ( name -- n )
 
-M: c-type c-type-align align>> ;
+M: abstract-c-type c-type-align align>> ;
 
 M: string c-type-align c-type c-type-align ;
 
@@ -129,13 +212,11 @@ M: c-type c-type-stack-align? stack-align?>> ;
 M: string c-type-stack-align? c-type c-type-stack-align? ;
 
 : c-type-box ( n type -- )
-    dup c-type-reg-class
+    [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
-    swap c-type-boxer [ "No boxer" throw ] unless*
     %box ;
 
 : c-type-unbox ( n ctype -- )
-    dup c-type-reg-class
+    [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
-    swap c-type-unboxer [ "No unboxer" throw ] unless*
     %unbox ;
 
 GENERIC: box-parameter ( n ctype -- )
@@ -162,15 +243,6 @@ M: c-type unbox-return f swap c-type-unbox ;
 
 M: string unbox-return c-type unbox-return ;
 
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
-GENERIC: heap-size ( type -- size ) foldable
-
-M: string heap-size c-type heap-size ;
-
-M: c-type heap-size size>> ;
-
 GENERIC: stack-size ( type -- size ) foldable
 
 M: string stack-size c-type stack-size ;
@@ -179,9 +251,9 @@ M: c-type stack-size size>> cell align ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
-M: byte-array byte-length length ;
+M: byte-array byte-length length ; inline
 
-M: f byte-length drop 0 ;
+M: f byte-length drop 0 ; inline
 
 : c-getter ( name -- quot )
     c-type-getter [
@@ -196,17 +268,17 @@ M: f byte-length drop 0 ;
         [ "Cannot write struct fields with this type" throw ]
     ] unless* ;
 
-: <c-array> ( n type -- array )
-    heap-size * <byte-array> ; inline
-
 : <c-object> ( type -- array )
-    1 swap <c-array> ; inline
+    heap-size <byte-array> ; inline
 
-: malloc-array ( n type -- alien )
+: (c-object) ( type -- array )
-    heap-size calloc ; inline
+    heap-size (byte-array) ; inline
 
 : malloc-object ( type -- alien )
-    1 swap malloc-array ; inline
+    1 swap heap-size calloc ; inline
+
+: (malloc-object) ( type -- alien )
+    heap-size malloc ; inline
 
 : malloc-byte-array ( byte-array -- alien )
     dup byte-length [ nip malloc dup ] 2keep memcpy ;
@@ -224,7 +296,7 @@ M: memory-stream stream-read
     ] [ [ + ] change-index drop ] 2bi ;
 
 : byte-array>memory ( byte-array base -- )
-    swap dup byte-length memcpy ;
+    swap dup byte-length memcpy ; inline
 
 : array-accessor ( type quot -- def )
     [
@@ -269,23 +341,38 @@ M: long-long-type box-return ( type -- )
     [ define-out ]
     tri ;
 
-: expand-constants ( c-type -- c-type' )
-    dup array? [
-        unclip [
-            [
-                dup word? [
-                    def>> call( -- object )
-                ] when
-            ] map
-        ] dip prefix
-    ] when ;
-
 : malloc-file-contents ( path -- alien len )
     binary file-contents [ malloc-byte-array ] [ length ] bi ;
 
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
+: ?lookup ( vocab word -- word/pair )
+    over vocab [ swap lookup ] [ 2array ] if ;
+
+: set-array-class* ( c-type vocab-stem type-stem -- c-type )
+    {
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-array" append ] bi* ?lookup >>array-class
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
+        ]
+    } 2cleave ;
+
+: set-array-class ( c-type stem -- c-type )
+    dup set-array-class* ;
+
 CONSTANT: primitive-types
     {
         "char" "uchar"
@@ -300,6 +387,7 @@ CONSTANT: primitive-types
 [
     <c-type>
         c-ptr >>class
+        c-ptr >>boxed-class
         [ alien-cell ] >>getter
         [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
         bootstrap-cell >>size
@@ -307,106 +395,127 @@ CONSTANT: primitive-types
         [ >c-ptr ] >>unboxer-quot
         "box_alien" >>boxer
         "alien_offset" >>unboxer
+        "alien" "void*" set-array-class*
     "void*" define-primitive-type
 
     <long-long-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
         8 >>align
         "box_signed_8" >>boxer
         "to_signed_8" >>unboxer
+        "longlong" set-array-class
     "longlong" define-primitive-type
 
     <long-long-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
         8 >>align
         "box_unsigned_8" >>boxer
         "to_unsigned_8" >>unboxer
+        "ulonglong" set-array-class
     "ulonglong" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-cell ] >>getter
         [ set-alien-signed-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
         "box_signed_cell" >>boxer
         "to_fixnum" >>unboxer
+        "long" set-array-class
     "long" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-cell ] >>getter
         [ set-alien-unsigned-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
         "box_unsigned_cell" >>boxer
         "to_cell" >>unboxer
+        "ulong" set-array-class
     "ulong" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-4 ] >>getter
         [ set-alien-signed-4 ] >>setter
         4 >>size
         4 >>align
         "box_signed_4" >>boxer
         "to_fixnum" >>unboxer
+        "int" set-array-class
     "int" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-4 ] >>getter
         [ set-alien-unsigned-4 ] >>setter
         4 >>size
         4 >>align
         "box_unsigned_4" >>boxer
         "to_cell" >>unboxer
+        "uint" set-array-class
     "uint" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-signed-2 ] >>getter
         [ set-alien-signed-2 ] >>setter
         2 >>size
         2 >>align
         "box_signed_2" >>boxer
         "to_fixnum" >>unboxer
+        "short" set-array-class
     "short" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-unsigned-2 ] >>getter
         [ set-alien-unsigned-2 ] >>setter
         2 >>size
         2 >>align
         "box_unsigned_2" >>boxer
         "to_cell" >>unboxer
+        "ushort" set-array-class
     "ushort" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-signed-1 ] >>getter
         [ set-alien-signed-1 ] >>setter
         1 >>size
         1 >>align
         "box_signed_1" >>boxer
         "to_fixnum" >>unboxer
+        "char" set-array-class
     "char" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-unsigned-1 ] >>getter
         [ set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
         "box_unsigned_1" >>boxer
         "to_cell" >>unboxer
+        "uchar" set-array-class
     "uchar" define-primitive-type
 
     <c-type>
@@ -416,33 +525,39 @@ CONSTANT: primitive-types
         1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
+        "bool" set-array-class
     "bool" define-primitive-type
 
     <c-type>
         float >>class
+        float >>boxed-class
         [ alien-float ] >>getter
         [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
         4 >>align
         "box_float" >>boxer
         "to_float" >>unboxer
-        single-float-regs >>reg-class
+        single-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "float" set-array-class
     "float" define-primitive-type
 
     <c-type>
         float >>class
+        float >>boxed-class
         [ alien-double ] >>getter
         [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
         8 >>align
         "box_double" >>boxer
         "to_double" >>unboxer
-        double-float-regs >>reg-class
+        double-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "double" set-array-class
     "double" define-primitive-type
 
     "long" "ptrdiff_t" typedef
     "long" "intptr_t" typedef
     "ulong" "size_t" typedef
 ] with-compilation-unit
+

basis/alien/complex/complex-tests.factor

@@ -1,18 +1,21 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex kernel alien.c-types alien.syntax
+USING: accessors tools.test alien.complex classes.struct kernel
-namespaces ;
+alien.c-types alien.syntax namespaces math ;
 IN: alien.complex.tests
 
-C-STRUCT: complex-holder
+STRUCT: complex-holder
-    { "complex-float" "z" } ;
+    { z complex-float } ;
 
 : <complex-holder> ( z -- alien )
-    "complex-holder" <c-object>
+    complex-holder <struct-boa> ;
-    [ set-complex-holder-z ] keep ;
 
 [ ] [
     C{ 1.0 2.0 } <complex-holder> "h" set
 ] unit-test
 
-[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
+[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
+
+[ number ] [ "complex-float" c-type-boxed-class ] unit-test
+
+[ number ] [ "complex-double" c-type-boxed-class ] unit-test

basis/alien/complex/complex.factor

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

basis/alien/complex/functor/functor-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex.functor ;
-IN: alien.complex.functor.tests

basis/alien/complex/functor/functor.factor

@@ -1,35 +1,32 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.c-types math math.functions sequences
+USING: accessors alien alien.structs alien.c-types classes.struct math
-arrays kernel functors vocabs.parser namespaces accessors
+math.functions sequences arrays kernel functors vocabs.parser
-quotations ;
+namespaces quotations ;
 IN: alien.complex.functor
 
 FUNCTOR: define-complex-type ( N T -- )
 
-T-real DEFINES ${T}-real
+T-class DEFINES-CLASS ${T}
-T-imaginary DEFINES ${T}-imaginary
-set-T-real DEFINES set-${T}-real
-set-T-imaginary DEFINES set-${T}-imaginary
 
 <T> DEFINES <${T}>
 *T DEFINES *${T}
 
 WHERE
 
+STRUCT: T-class { real N } { imaginary N } ;
+
 : <T> ( z -- alien )
-    >rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
+    >rect T-class <struct-boa> >c-ptr ;
 
 : *T ( alien -- z )
-    [ T-real ] [ T-imaginary ] bi rect> ; inline
+    T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
 
-T current-vocab
+T-class c-type
-{ { N "real" } { N "imaginary" } }
-define-struct
-
-T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
+number >>boxed-class
+T set-array-class
 drop
 
 ;FUNCTOR

basis/alien/destructors/destructors-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests

basis/alien/destructors/destructors.factor

@@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words
 effects generalizations sequences ;
 IN: alien.destructors
 
-SLOT: alien
+TUPLE: alien-destructor alien ;
 
 FUNCTOR: define-destructor ( F -- )
 
@@ -16,11 +16,12 @@ N [ F stack-effect out>> length ]
 
 WHERE
 
-TUPLE: F-destructor alien disposed ;
+TUPLE: F-destructor < alien-destructor ;
 
-: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
+: <F-destructor> ( alien -- destructor )
+    F-destructor boa ; inline
 
-M: F-destructor dispose* alien>> F N ndrop ;
+M: F-destructor dispose alien>> F N ndrop ;
 
 : &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
 

basis/alien/fortran/fortran.factor

@@ -357,15 +357,15 @@ M: character-type (<fortran-result>)
 
 : (shuffle-map) ( return parameters -- ret par )
     [
-        fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
+        fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
         letters swap head [ "ret" swap suffix ] map
     ] [
-        [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
+        [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
         [ first2 letters swap head [ "" 2sequence ] with map ] map concat
     ] bi* ;
 
 : (fortran-in-shuffle) ( ret par -- seq )
-    [ [ second ] bi@ <=> ] sort append ;
+    [ second ] sort-with append ;
 
 : (fortran-out-shuffle) ( ret par -- seq )
     append ;

basis/alien/libraries/libraries-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.syntax assocs help.markup
-help.syntax io.backend kernel namespaces ;
+help.syntax io.backend kernel namespaces strings ;
 IN: alien.libraries
 
 HELP: <library>
@@ -15,7 +15,7 @@ HELP: libraries
 { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
 
 HELP: library
-{ $values { "name" "a string" } { "library" assoc } }
+{ $values { "name" string } { "library" assoc } }
 { $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" }
@@ -40,11 +40,11 @@ HELP: dlclose ( dll -- )
 { $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
 
 HELP: load-library
-{ $values { "name" "a string" } { "dll" "a DLL handle" } }
+{ $values { "name" string } { "dll" "a DLL handle" } }
 { $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" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
+{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
 { $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
 { $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
 $nl
@@ -59,9 +59,14 @@ $nl
 }
 "Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
 
+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." } ;
+
 ARTICLE: "loading-libs" "Loading native libraries"
 "Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
 { $subsection add-library }
+{ $subsection remove-library }
 "Once a library has been defined, you can try loading it to see if the path name is correct:"
 { $subsection 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." ;

basis/alien/libraries/libraries-tests.factor

@@ -0,0 +1,10 @@
+USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
+
+[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
+
+[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
+
+[ ] [ "doesnotexist" dlopen dlclose ] unit-test
+
+[ "fdasfsf" dll-valid? drop ] must-fail

basis/alien/libraries/libraries.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
+USING: accessors alien alien.strings assocs io.backend
+kernel namespaces destructors ;
 IN: alien.libraries
 
 : dlopen ( path -- dll ) native-string>alien (dlopen) ;
@@ -21,5 +22,13 @@ TUPLE: library path abi dll ;
 : load-library ( name -- dll )
     library dup [ dll>> ] when ;
 
+M: dll dispose dlclose ;
+
+M: library dispose dll>> [ dispose ] when* ;
+
+: remove-library ( name -- )
+    libraries get delete-at* [ dispose ] [ drop ] if ;
+
 : add-library ( name path abi -- )
-    <library> swap libraries get set-at ;
+    [ 2drop remove-library ]
+    [ <library> swap libraries get set-at ] 3bi ;

basis/alien/parser/parser.factor

@@ -1,18 +1,30 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces ;
+parser sequences splitting words fry locals lexer namespaces
+summary math ;
 IN: alien.parser
 
+: normalize-c-arg ( type name -- type' name' )
+    [ length ]
+    [
+        [ CHAR: * = ] trim-head
+        [ length - CHAR: * <array> append ] keep
+    ] bi ;
+
 : parse-arglist ( parameters return -- types effect )
-    [ 2 group unzip [ "," ?tail drop ] map ]
+    [
+        2 group [ first2 normalize-c-arg 2array ] map
+        unzip [ "," ?tail drop ] map
+    ]
     [ [ { } ] [ 1array ] if-void ]
     bi* <effect> ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return library function parameters -- word quot effect )
+:: make-function ( return! library function! parameters -- word quot effect )
+    return function normalize-c-arg function! return!
     function create-in dup reset-generic
     return library function
     parameters return parse-arglist [ function-quot ] dip ;

basis/alien/structs/fields/fields.factor

@@ -7,16 +7,16 @@ IN: alien.structs.fields
 TUPLE: field-spec name offset type reader writer ;
 
 : reader-word ( class name vocab -- word )
-    [ "-" glue ] dip create ;
+    [ "-" glue ] dip create dup make-deprecated ;
 
 : writer-word ( class name vocab -- word )
-    [ [ swap "set-" % % "-" % % ] "" make ] dip create ;
+    [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
 
 : <field-spec> ( struct-name vocab type field-name -- spec )
     field-spec new
         0 >>offset
         swap >>name
-        swap expand-constants >>type
+        swap >>type
         3dup name>> swap reader-word >>reader
         3dup name>> swap writer-word >>writer
     2nip ;

basis/alien/structs/structs-docs.factor

@@ -23,11 +23,11 @@ $nl
 }
 "C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
-"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
+"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
 
 ARTICLE: "c-unions" "C unions"
 "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
 { $subsection POSTPONE: C-UNION: }
 "C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
-"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
+"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;

basis/alien/structs/structs-tests.factor

@@ -1,6 +1,6 @@
-IN: alien.structs.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc words vocabs namespaces layouts ;
+IN: alien.structs.tests
 
 C-STRUCT: bar
     { "int" "x" }

basis/alien/structs/structs.factor

@@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
 quotations byte-arrays ;
 IN: alien.structs
 
-TUPLE: struct-type
+TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
-size
-align
-fields
-{ boxer-quot callable }
-{ unboxer-quot callable }
-{ getter callable }
-{ setter callable }
-return-in-registers? ;
 
 M: struct-type c-type ;
 
-M: struct-type heap-size size>> ;
-
-M: struct-type c-type-class drop byte-array ;
-
-M: struct-type c-type-align align>> ;
-
 M: struct-type c-type-stack-align? drop f ;
 
-M: struct-type c-type-boxer-quot boxer-quot>> ;
-
-M: struct-type c-type-unboxer-quot unboxer-quot>> ;
-
 : if-value-struct ( ctype true false -- )
     [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
 
@@ -53,9 +35,10 @@ M: struct-type stack-size
 
 : c-struct? ( type -- ? ) (c-type) struct-type? ;
 
-: (define-struct) ( name size align fields -- )
+: (define-struct) ( name size align fields class -- )
-    [ [ align ] keep ] dip
+    [ [ align ] keep ] 2dip new
-    struct-type new
+        byte-array >>class
+        byte-array >>boxed-class
         swap >>fields
         swap >>align
         swap >>size
@@ -71,14 +54,16 @@ M: struct-type stack-size
     [ 2drop ] [ make-fields ] 3bi
     [ struct-offsets ] keep
     [ [ type>> ] map compute-struct-align ] keep
-    [ (define-struct) ] keep
+    [ struct-type (define-struct) ] keep
-    [ define-field ] each ;
+    [ define-field ] each ; deprecated
 
 : define-union ( name members -- )
-    [ expand-constants ] map
     [ [ heap-size ] [ max ] map-reduce ] keep
-    compute-struct-align f (define-struct) ;
+    compute-struct-align f struct-type (define-struct) ; deprecated
 
 : offset-of ( field struct -- offset )
     c-types get at fields>> 
     [ name>> = ] with find nip offset>> ;
+
+USE: vocabs.loader
+"struct-arrays" require

basis/alien/syntax/syntax-docs.factor

@@ -1,6 +1,6 @@
 IN: alien.syntax
 USING: alien alien.c-types alien.parser alien.structs
-help.markup help.syntax ;
+classes.struct help.markup help.syntax ;
 
 HELP: DLL"
 { $syntax "DLL\" path\"" }
@@ -55,12 +55,14 @@ HELP: TYPEDEF:
 { $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-STRUCT:
+{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
 { $syntax "C-STRUCT: name pairs... ;" }
 { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
 { $description "Defines a C struct layout and accessor words." }
 { $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
 
 HELP: C-UNION:
+{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
 { $syntax "C-UNION: name members... ;" }
 { $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
 { $description "Defines a new C type sized to fit its largest member." }

basis/alien/syntax/syntax.factor

@@ -22,17 +22,19 @@ SYNTAX: TYPEDEF:
     scan scan typedef ;
 
 SYNTAX: C-STRUCT:
-    scan current-vocab parse-definition define-struct ;
+    scan current-vocab parse-definition define-struct ; deprecated
 
 SYNTAX: C-UNION:
-    scan parse-definition define-union ;
+    scan parse-definition define-union ; deprecated
 
 SYNTAX: C-ENUM:
     ";" parse-tokens
     [ [ create-in ] dip define-constant ] each-index ;
 
+ERROR: no-such-symbol name library ;
+
 : address-of ( name library -- value )
-    load-library dlsym [ "No such symbol" throw ] unless* ;
+    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
 
 SYNTAX: &:
     scan "c-library" get '[ _ _ address-of ] over push-all ;

basis/ascii/ascii-tests.factor

@@ -10,7 +10,7 @@ IN: ascii.tests
 
 [ 4 ] [
     0 "There are Four Upper Case characters"
-    [ LETTER? [ 1+ ] when ] each
+    [ LETTER? [ 1 + ] when ] each
 ] unit-test
 
 [ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test

basis/base64/base64.factor

@@ -34,7 +34,7 @@ SYMBOL: column
 : write1-lines ( ch -- )
     write1
     column get [
-        1+ [ 76 = [ crlf ] when ]
+        1 + [ 76 = [ crlf ] when ]
         [ 76 mod column set ] bi
     ] when* ;
 
@@ -48,7 +48,7 @@ SYMBOL: column
 
 : encode-pad ( seq n -- )
     [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
-    [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
+    [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 
 : decode4 ( seq -- )
     [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]

basis/biassocs/biassocs-tests.factor

@@ -1,5 +1,5 @@
+USING: biassocs assocs namespaces tools.test hashtables kernel ;
 IN: biassocs.tests
-USING: biassocs assocs namespaces tools.test ;
 
 <bihash> "h" set
 
@@ -29,4 +29,14 @@ H{ { "a" "A" } { "b" "B" } } "a" set
 
 [ "A" ] [ "a" "b" get at ] unit-test
 
-[ "a" ] [ "A" "b" get value-at ] unit-test
+[ "a" ] [ "A" "b" get value-at ] unit-test
+
+[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
+
+[ ] [ "h" get clone "g" set ] unit-test
+
+[ ] [ 3 4 "g" get set-at ] unit-test
+
+[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
+
+[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

basis/biassocs/biassocs.factor

@@ -43,4 +43,7 @@ M: biassoc new-assoc
 INSTANCE: biassoc assoc
 
 : >biassoc ( assoc -- biassoc )
-    T{ biassoc } assoc-clone-like ;
+    T{ biassoc } assoc-clone-like ;
+
+M: biassoc clone
+    [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

basis/binary-search/binary-search-tests.factor

@@ -1,5 +1,5 @@
-IN: binary-search.tests
 USING: binary-search math.order vectors kernel tools.test ;
+IN: binary-search.tests
 
 [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
 [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
@@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
 [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 [ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
 
-[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
-[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
-[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
-[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -27,46 +27,63 @@ TUPLE: bit-array
     [ [ length bits>cells ] keep ] dip swap underlying>>
     '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
 
+: clean-up ( bit-array -- )
+    ! Zero bits after the end.
+    dup underlying>> empty? [ drop ] [
+        [
+            [ underlying>> length 8 * ] [ length ] bi -
+            8 swap - -1 swap shift bitnot
+        ]
+        [ underlying>> last bitand ]
+        [ underlying>> set-last ]
+        tri
+    ] if ; inline
+
 PRIVATE>
 
 : <bit-array> ( n -- bit-array )
     dup bits>bytes <byte-array> bit-array boa ; inline
 
-M: bit-array length length>> ;
+M: bit-array length length>> ; inline
 
 M: bit-array nth-unsafe
-    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
 
 M: bit-array set-nth-unsafe
     [ >fixnum ] [ underlying>> ] bi*
     [ byte/bit set-bit ] 2keep
-    swap n>byte set-alien-unsigned-1 ;
+    swap n>byte set-alien-unsigned-1 ; inline
 
-: clear-bits ( bit-array -- ) 0 (set-bits) ;
+GENERIC: clear-bits ( bit-array -- )
 
-: set-bits ( bit-array -- ) -1 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ; inline
+
+GENERIC: set-bits ( bit-array -- )
+
+M: bit-array set-bits -1 (set-bits) ; inline
 
 M: bit-array clone
-    [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+    [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
 
 : >bit-array ( seq -- bit-array )
     T{ bit-array f 0 B{ } } clone-like ; inline
 
-M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
 
-M: bit-array new-sequence drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
 
 M: bit-array equal?
-    over bit-array? [ sequence= ] [ 2drop f ] if ;
+    over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
 
 M: bit-array resize
     [ drop ] [
         [ bits>bytes ] [ underlying>> ] bi*
         resize-byte-array
     ] 2bi
-    bit-array boa ;
+    bit-array boa
+    dup clean-up ; inline
 
-M: bit-array byte-length length 7 + -3 shift ;
+M: bit-array byte-length length 7 + -3 shift ; inline
 
 SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
 
@@ -74,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
     dup 0 = [
         <bit-array>
     ] [
-        [ log2 1+ <bit-array> 0 ] keep
+        [ log2 1 + <bit-array> 0 ] keep
         [ dup 0 = ] [
             [ pick underlying>> pick set-alien-unsigned-1 ] keep
-            [ 1+ ] [ -8 shift ] bi*
+            [ 1 + ] [ -8 shift ] bi*
         ] until 2drop
     ] if ;
 

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

@@ -0,0 +1,17 @@
+USING: bit-sets tools.test bit-arrays ;
+IN: bit-sets.tests
+
+[ ?{ t f t f t f } ] [
+    ?{ t f f f t f }
+    ?{ f f t f t f } bit-set-union
+] unit-test
+
+[ ?{ f f f f t f } ] [
+    ?{ t f f f t f }
+    ?{ f f t f t f } bit-set-intersect
+] unit-test
+
+[ ?{ t f t f f f } ] [
+    ?{ t t t f f f }
+    ?{ f t f f t t } bit-set-diff
+] unit-test

basis/bit-sets/bit-sets.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+IN: bit-sets
+
+<PRIVATE
+
+: bit-set-map ( seq1 seq2 quot -- seq )
+    [ 2drop length>> ]
+    [
+        [
+            [ [ length ] bi@ assert= ]
+            [ [ underlying>> ] bi@ ] 2bi
+        ] dip 2map
+    ] 3bi bit-array boa ; inline
+
+PRIVATE>
+
+: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+
+HINTS: bit-set-union bit-array bit-array ;
+
+: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+
+HINTS: bit-set-intersect bit-array bit-array ;
+
+: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+
+HINTS: bit-set-diff bit-array bit-array ;
+
+: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;

basis/bit-sets/summary.txt

@@ -0,0 +1 @@
+Efficient bitwise operations on bit arrays

basis/bit-vectors/bit-vectors-docs.factor

@@ -22,11 +22,11 @@ HELP: bit-vector
 { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
 
 HELP: <bit-vector>
-{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
+{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
 { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
 
 HELP: >bit-vector
-{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
+{ $values { "seq" "a sequence" } { "vector" bit-vector } }
 { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
 
 HELP: ?V{

basis/bit-vectors/bit-vectors-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-vectors.tests
 USING: tools.test bit-vectors vectors sequences kernel math ;
+IN: bit-vectors.tests
 
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 

basis/bit-vectors/bit-vectors.factor

@@ -1,38 +1,15 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
 sequences.private growable bit-arrays prettyprint.custom
-parser accessors ;
+parser accessors vectors.functor classes.parser ;
 IN: bit-vectors
 
-TUPLE: bit-vector
+<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
-{ underlying bit-array initial: ?{ } }
-{ length array-capacity } ;
-
-: <bit-vector> ( n -- bit-vector )
-    <bit-array> 0 bit-vector boa ; inline
-
-: >bit-vector ( seq -- bit-vector )
-    T{ bit-vector f ?{ } 0 } clone-like ;
-
-M: bit-vector like
-    drop dup bit-vector? [
-        dup bit-array?
-        [ dup length bit-vector boa ] [ >bit-vector ] if
-    ] unless ;
-
-M: bit-vector new-sequence
-    drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
-
-M: bit-vector equal?
-    over bit-vector? [ sequence= ] [ 2drop f ] if ;
-
-M: bit-array new-resizable drop <bit-vector> ;
-
-INSTANCE: bit-vector growable
 
 SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
 
+M: bit-vector contract 2drop ;
 M: bit-vector >pprint-sequence ;
 M: bit-vector pprint-delims drop \ ?V{ \ } ;
 M: bit-vector pprint* pprint-object ;

basis/bitstreams/bitstreams-tests.factor

@@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-
 [ BIN: 1111111111 ]
 [
     B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

basis/bitstreams/bitstreams.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.accessors assocs byte-arrays combinators
-constructors destructors fry io io.binary io.encodings.binary
+destructors fry io io.binary io.encodings.binary io.streams.byte-array
-io.streams.byte-array kernel locals macros math math.ranges
+kernel locals macros math math.ranges multiline sequences
-multiline sequences sequences.private vectors byte-vectors
+sequences.private vectors byte-vectors combinators.short-circuit
-combinators.short-circuit math.bitwise ;
+math.bitwise ;
 IN: bitstreams
 
 TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@@ -36,8 +36,12 @@ TUPLE: bit-writer
 
 TUPLE: msb0-bit-reader < bit-reader ;
 TUPLE: lsb0-bit-reader < bit-reader ;
-CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
+
-CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+: <msb0-bit-reader> ( bytes -- bs )
+    msb0-bit-reader new swap >>bytes ; inline
+
+: <lsb0-bit-reader> ( bytes -- bs )
+    lsb0-bit-reader new swap >>bytes ; inline
 
 TUPLE: msb0-bit-writer < bit-writer ;
 TUPLE: lsb0-bit-writer < bit-writer ;
@@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
 GENERIC: peek ( n bitstream -- value )
 GENERIC: poke ( value n bitstream -- )
 
+: get-abp ( bitstream -- abp ) 
+    [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
+    
+: set-abp ( abp bitstream -- ) 
+    [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
+
 : seek ( n bitstream -- )
-    {
+    [ get-abp + ] [ set-abp ] bi ; inline
-        [ byte-pos>> 8 * ]
+    
-        [ bit-pos>> + + 8 /mod ]
+: (align) ( n m -- n' )
-        [ (>>bit-pos) ]
+    [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
-        [ (>>byte-pos) ]
+    
-    } cleave ; inline
+: align ( n bitstream -- )
+    [ get-abp swap (align) ] [ set-abp ] bi ; inline
 
 : read ( n bitstream -- value )
     [ peek ] [ seek ] 2bi ; inline

basis/bootstrap/compiler/compiler.factor

@@ -6,11 +6,14 @@ classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
 io.encodings.string libc splitting math.parser memory compiler.units
-math.order compiler.tree.builder compiler.tree.optimizer
+math.order quotations quotations.private assocs.private ;
-compiler.cfg.optimizer ;
+FROM: compiler => enable-optimizer ;
-FROM: compiler => enable-optimizer compile-word ;
 IN: bootstrap.compiler
 
+"profile-compiler" get [
+    "bootstrap.compiler.timing" require
+] when
+
 ! Don't bring this in when deploying, since it will store a
 ! reference to 'eval' in a global variable
 "deploy-vocab" get "staging" get or [
@@ -32,90 +35,87 @@ gc
 : compile-unoptimized ( words -- )
     [ optimized? not ] filter compile ;
 
-nl
+"debug-compiler" get [
-"Compiling..." write flush
+    
+    nl
+    "Compiling..." write flush
 
-! Compile a set of words ahead of the full compile.
+    ! Compile a set of words ahead of the full compile.
-! This set of words was determined semi-empirically
+    ! This set of words was determined semi-empirically
-! using the profiler. It improves bootstrap time
+    ! using the profiler. It improves bootstrap time
-! significantly, because frequenly called words
+    ! significantly, because frequenly called words
-! which are also quick to compile are replaced by
+    ! which are also quick to compile are replaced by
-! compiled definitions as soon as possible.
+    ! compiled definitions as soon as possible.
-{
+    {
-    not
+        not ?
 
-    array? hashtable? vector?
+        2over roll -roll
-    tuple? sbuf? tombstone?
 
-    array-nth set-array-nth
+        array? hashtable? vector?
+        tuple? sbuf? tombstone?
+        curry? compose? callable?
+        quotation?
 
-    wrap probe
+        curry compose uncurry
 
-    namestack*
+        array-nth set-array-nth length>>
-} compile-unoptimized
 
-"." write flush
+        wrap probe
 
-{
+        namestack*
-    bitand bitor bitxor bitnot
-} compile-unoptimized
 
-"." write flush
+        layout-of
+    } compile-unoptimized
 
-{
+    "." write flush
-    + 1+ 1- 2/ < <= > >= shift
-} compile-unoptimized
 
-"." write flush
+    {
+        bitand bitor bitxor bitnot
+    } compile-unoptimized
 
-{
+    "." write flush
-    new-sequence nth push pop last flip
-} compile-unoptimized
 
-"." write flush
+    {
+        + 2/ < <= > >= shift
+    } compile-unoptimized
 
-{
+    "." write flush
-    hashcode* = get set
-} compile-unoptimized
 
-"." write flush
+    {
+        new-sequence nth push pop last flip
+    } compile-unoptimized
 
-{
+    "." write flush
-    memq? split harvest sift cut cut-slice start index clone
-    set-at reverse push-all class number>string string>number
-} compile-unoptimized
 
-"." write flush
+    {
+        hashcode* = equal? assoc-stack (assoc-stack) get set
+    } compile-unoptimized
 
-{
+    "." write flush
-    lines prefix suffix unclip new-assoc update
-    word-prop set-word-prop 1array 2array 3array ?nth
-} compile-unoptimized
 
-"." write flush
+    {
+        memq? split harvest sift cut cut-slice start index clone
+        set-at reverse push-all class number>string string>number
+        like clone-like
+    } compile-unoptimized
 
-{
+    "." write flush
-    malloc calloc free memcpy
-} compile-unoptimized
 
-"." write flush
+    {
+        lines prefix suffix unclip new-assoc update
+        word-prop set-word-prop 1array 2array 3array ?nth
+    } compile-unoptimized
 
-{ build-tree } compile-unoptimized
+    "." write flush
 
-"." write flush
+    {
+        malloc calloc free memcpy
+    } compile-unoptimized
 
-{ optimize-tree } compile-unoptimized
+    "." write flush
 
-"." write flush
+    vocabs [ words compile-unoptimized "." write flush ] each
 
-{ optimize-cfg } compile-unoptimized
+    " done" print flush
 
-"." write flush
+] unless
-
-{ compile-word } compile-unoptimized
-
-"." write flush
-
-vocabs [ words compile-unoptimized "." write flush ] each
-
-" done" print flush

basis/bootstrap/compiler/timing/timing.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel make sequences tools.annotations tools.crossref ;
+QUALIFIED: compiler.cfg.builder
+QUALIFIED: compiler.cfg.linear-scan
+QUALIFIED: compiler.cfg.mr
+QUALIFIED: compiler.cfg.optimizer
+QUALIFIED: compiler.cfg.stacks.finalize
+QUALIFIED: compiler.cfg.stacks.global
+QUALIFIED: compiler.codegen
+QUALIFIED: compiler.tree.builder
+QUALIFIED: compiler.tree.optimizer
+IN: bootstrap.compiler.timing
+
+: passes ( word -- seq )
+    def>> uses [ vocabulary>> "compiler." head? ] filter ;
+
+: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
+
+: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
+
+: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
+
+: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
+
+: all-passes ( -- seq )
+    [
+        \ compiler.tree.builder:build-tree ,
+        \ compiler.tree.optimizer:optimize-tree ,
+        high-level-passes %
+        \ compiler.cfg.builder:build-cfg ,
+        \ compiler.cfg.stacks.global:compute-global-sets ,
+        \ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
+        \ compiler.cfg.optimizer:optimize-cfg ,
+        low-level-passes %
+        \ compiler.cfg.mr:build-mr ,
+        machine-passes %
+        linear-scan-passes %
+        \ compiler.codegen:generate ,
+    ] { } make ;
+
+all-passes [ [ reset ] [ add-timing ] bi ] each

basis/bootstrap/image/image-tests.factor

@@ -1,6 +1,6 @@
-IN: bootstrap.image.tests
 USING: bootstrap.image bootstrap.image.private tools.test
 kernel math ;
+IN: bootstrap.image.tests
 
 [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
 

basis/bootstrap/image/image.factor

@@ -38,11 +38,11 @@ IN: bootstrap.image
 
 ! Object cache; we only consider numbers equal if they have the
 ! same type
-TUPLE: id obj ;
+TUPLE: eql-wrapper obj ;
 
-C: <id> id
+C: <eql-wrapper> eql-wrapper
 
-M: id hashcode* obj>> hashcode* ;
+M: eql-wrapper hashcode* obj>> hashcode* ;
 
 GENERIC: (eql?) ( obj1 obj2 -- ? )
 
@@ -62,19 +62,27 @@ M: sequence (eql?)
 
 M: object (eql?) = ;
 
-M: id equal?
+M: eql-wrapper equal?
-    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+    over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+TUPLE: eq-wrapper obj ;
+
+C: <eq-wrapper> eq-wrapper
+
+M: eq-wrapper equal?
+    over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
 
 SYMBOL: objects
 
-: (objects) ( obj -- id assoc ) <id> objects get ; inline
+: cache-eql-object ( obj quot -- value )
+    [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
 
-: lookup-object ( obj -- n/f ) (objects) at ;
+: cache-eq-object ( obj quot -- value )
+    [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
 
-: put-object ( n obj -- ) (objects) set-at ;
+: lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
 
-: cache-object ( obj quot -- value )
+: put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
-    [ (objects) ] dip '[ obj>> @ ] cache ; inline
 
 ! Constants
 
@@ -234,7 +242,7 @@ GENERIC: ' ( obj -- ptr )
 
 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 
-: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 
 : bignum>seq ( n -- seq )
     #! n is positive or zero.
@@ -244,7 +252,7 @@ GENERIC: ' ( obj -- ptr )
 
 : emit-bignum ( n -- )
     dup dup 0 < [ neg ] when bignum>seq
-    [ nip length 1+ emit-fixnum ]
+    [ nip length 1 + emit-fixnum ]
     [ drop 0 < 1 0 ? emit ]
     [ nip emit-seq ]
     2tri ;
@@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr )
 M: bignum '
     [
         bignum [ emit-bignum ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Fixnums
 
@@ -277,7 +285,7 @@ M: float '
         float [
             align-here double>bits emit-64
         ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Special objects
 
@@ -340,7 +348,7 @@ M: word ' ;
 ! Wrappers
 
 M: wrapper '
-    wrapped>> ' wrapper [ emit ] emit-object ;
+    [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
 
 ! Strings
 : native> ( object -- object )
@@ -379,7 +387,7 @@ M: wrapper '
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    [ emit-string ] cache-object ;
+    [ emit-string ] cache-eql-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -390,10 +398,12 @@ M: string '
     ] bi* ;
 
 M: byte-array '
-    byte-array [
+    [
-        dup length emit-fixnum
+        byte-array [
-        pad-bytes emit-bytes
+            dup length emit-fixnum
-    ] emit-object ;
+            pad-bytes emit-bytes
+        ] emit-object
+    ] cache-eq-object ;
 
 ! Tuples
 ERROR: tuple-removed class ;
@@ -408,20 +418,22 @@ ERROR: tuple-removed class ;
 
 : emit-tuple ( tuple -- pointer )
     dup class name>> "tombstone" =
-    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-eql-object ]
+    [ [ (emit-tuple) ] cache-eq-object ]
+    if ;
 
 M: tuple ' emit-tuple ;
 
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
     "hashtables.private" lookup def>> first
-    [ emit-tuple ] cache-object ;
+    [ emit-tuple ] cache-eql-object ;
 
 ! Arrays
 : emit-array ( array -- offset )
     [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
-M: array ' emit-array ;
+M: array ' [ emit-array ] cache-eq-object ;
 
 ! This is a hack. We need to detect arrays which are tuple
 ! layout arrays so that they can be internalized, but making
@@ -438,7 +450,7 @@ M: tuple-layout-array '
     [
         [ dup integer? [ <fake-bignum> ] when ] map
         emit-array
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Quotations
 
@@ -452,7 +464,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! End of the image
 

basis/bootstrap/image/upload/upload.factor

@@ -9,9 +9,9 @@ IN: bootstrap.image.upload
 SYMBOL: upload-images-destination
 
 : destination ( -- dest )
-  upload-images-destination get
+    upload-images-destination get
-  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+    "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
-  or ;
+    or ;
 
 : checksums ( -- temp ) "checksums.txt" temp-file ;
 

basis/bootstrap/math/math.factor

@@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ;
 
 "math.ratios" require
 "math.floats" require
-"math.complex" require
+"math.complex" require

basis/bootstrap/tools/tools.factor

@@ -8,12 +8,14 @@ IN: bootstrap.tools
     "tools.crossref"
     "tools.errors"
     "tools.deploy"
+    "tools.destructors"
     "tools.disassembler"
     "tools.memory"
     "tools.profiler"
     "tools.test"
     "tools.time"
     "tools.threads"
+    "tools.deprecation"
     "vocabs.hierarchy"
     "vocabs.refresh"
     "vocabs.refresh.monitor"

basis/boxes/boxes-tests.factor

@@ -1,5 +1,5 @@
-IN: boxes.tests
 USING: boxes namespaces tools.test accessors ;
+IN: boxes.tests
 
 [ ] [ <box> "b" set ] unit-test
 

basis/byte-arrays/hex/authors.txt

@@ -0,0 +1,2 @@
+Maxim Savchenko
+Slava Pestov

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

@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: byte-arrays.hex
+USING: byte-arrays help.markup help.syntax ;
+
+HELP: HEX{
+{ $syntax "HEX{ 0123 45 67 89abcdef }" }
+{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ;

basis/byte-arrays/hex/hex.factor

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

basis/cache/cache-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests

basis/cache/cache.factor

@@ -3,10 +3,10 @@
 USING: kernel assocs math accessors destructors fry sequences ;
 IN: cache
 
-TUPLE: cache-assoc assoc max-age disposed ;
+TUPLE: cache-assoc < disposable assoc max-age ;
 
 : <cache-assoc> ( -- cache )
-    H{ } clone 10 f cache-assoc boa ;
+    cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ;
 
 <PRIVATE
 
@@ -38,6 +38,6 @@ PRIVATE>
 
 : purge-cache ( cache -- )
     dup max-age>> '[
-        [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
+        [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
         [ values dispose-each ] dip
-    ] change-assoc drop ;
+    ] change-assoc drop ;

basis/cairo/cairo-tests.factor

@@ -1,8 +1,8 @@
-IN: cairo.tests
 USING: cairo tools.test math.rectangles accessors ;
+IN: cairo.tests
 
 [ { 10 20 } ] [
     { 10 20 } [
         { 0 1 } { 3 4 } <rect> fill-rect
     ] make-bitmap-image dim>>
-] unit-test
+] unit-test

basis/cairo/cairo.factor

@@ -31,7 +31,8 @@ ERROR: cairo-error message ;
         <cairo> &cairo_destroy
         @
     ] make-memory-bitmap
-    BGRA >>component-order ; inline
+    BGRA >>component-order
+    ubyte-components >>component-type ; inline
 
 : dummy-cairo ( -- cr )
     #! Sometimes we want a dummy context; eg with Pango, we want

basis/cairo/ffi/ffi.factor

@@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
 cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
 
 FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
 
 FUNCTION: cairo_status_t
 cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;

basis/calendar/calendar-docs.factor

@@ -20,14 +20,14 @@ HELP: <date>
 { $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
 { $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
 { $examples
-    { $example "USING: calendar prettyprint ;"
+    { $example "USING: accessors calendar prettyprint ;"
-               "2010 12 25 <date> >gmt midnight ."
+               "2010 12 25 <date> instant >>gmt-offset ."
                "T{ timestamp { year 2010 } { month 12 } { day 25 } }"
     }
 } ;
 
 HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
 { $description "Returns an array with the English names of all the months." }
 { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
 

basis/calendar/calendar.factor

@@ -34,25 +34,25 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
 M: not-a-month summary
     drop "Months are indexed starting at 1" ;
 
 <PRIVATE
 
 : check-month ( n -- n )
-    dup zero? [ not-a-month ] when ;
+    [ not-a-month ] when-zero ;
 
 PRIVATE>
 
-: month-names ( -- array )
+CONSTANT: month-names 
     {
         "January" "February" "March" "April" "May" "June"
         "July" "August" "September" "October" "November" "December"
-    } ;
+    }
 
 : month-name ( n -- string )
-    check-month 1- month-names nth ;
+    check-month 1 - month-names nth ;
 
 CONSTANT: month-abbreviations
     {
@@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
     }
 
 : month-abbreviation ( n -- string )
-    check-month 1- month-abbreviations nth ;
+    check-month 1 - month-abbreviations nth ;
 
 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
 
@@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
     100 b * d + 4800 -
     m 10 /i + m 3 +
     12 m 10 /i * -
-    e 153 m * 2 + 5 /i - 1+ ;
+    e 153 m * 2 + 5 /i - 1 + ;
 
 GENERIC: easter ( obj -- obj' )
 
@@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
     { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
     [ 3 >>month 1 >>day ] when ;
 
-: unless-zero ( n quot -- )
-    [ dup zero? [ drop ] ] dip if ; inline
-
 M: integer +year ( timestamp n -- timestamp )
     [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
 
@@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
     [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
 
 : months/years ( n -- months years )
-    12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+    12 /rem [ 1 - 12 ] when-zero swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
     [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
@@ -371,10 +368,10 @@ M: duration time-
     #! http://web.textfiles.com/computers/formulas.txt
     #! good for any date since October 15, 1582
     [
-        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
+        dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
         [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
-        [ 1+ 3 * 5 /i + ] keep 2 * +
+        [ 1 + 3 * 5 /i + ] keep 2 * +
-    ] dip 1+ + 7 mod ;
+    ] dip 1 + + 7 mod ;
 
 GENERIC: days-in-year ( obj -- n )
 
@@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
     year leap-year? [
         year month day <date>
         year 3 1 <date>
-        after=? [ 1+ ] when
+        after=? [ 1 + ] when
     ] when ;
 
 : day-of-year ( timestamp -- n )

basis/calendar/format/format.factor

@@ -68,8 +68,8 @@ M: array month. ( pair -- )
     [ (days-in-month) day-abbreviations2 " " join print ] 2tri
     over "   " <repetition> concat write
     [
-        [ 1+ day. ] keep
+        [ 1 + day. ] keep
-        1+ + 7 mod zero? [ nl ] [ bl ] if
+        1 + + 7 mod zero? [ nl ] [ bl ] if
     ] with each nl ;
 
 M: timestamp month. ( timestamp -- )
@@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
 GENERIC: year. ( obj -- )
 
 M: integer year. ( n -- )
-    12 [ 1+ 2array month. nl ] with each ;
+    12 [ 1 + 2array month. nl ] with each ;
 
 M: timestamp year. ( timestamp -- )
     year>> year. ;
@@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
 
 : read-rfc3339-seconds ( s -- s' ch )
     "+-Z" read-until [
-        [ string>number ] [ length 10 swap ^ ] bi / +
+        [ string>number ] [ length 10^ ] bi / +
     ] dip ;
 
 : (rfc3339>timestamp) ( -- timestamp )
@@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token day-abbreviations3 member? check-timestamp drop
         read1 CHAR: \s assert=
         read-sp checked-number >>day
-        read-sp month-abbreviations index 1+ check-timestamp >>month
+        read-sp month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token check-day-name
         read1 CHAR: \s assert=
         "-" read-token checked-number >>day
-        "-" read-token month-abbreviations index 1+ check-timestamp >>month
+        "-" read-token month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
 : (cookie-string>timestamp-2) ( -- timestamp )
     timestamp new
         read-sp check-day-name
-        read-sp month-abbreviations index 1+ check-timestamp >>month
+        read-sp month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>day
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute

basis/calendar/unix/unix.factor

@@ -1,28 +1,27 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time namespaces system ;
+kernel math unix unix.time unix.types namespaces system
+accessors classes.struct ;
 IN: calendar.unix
 
 : timeval>seconds ( timeval -- seconds )
-    [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+    [ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
-    time+ ;
 
 : timeval>unix-time ( timeval -- timestamp )
     timeval>seconds since-1970 ;
 
 : timespec>seconds ( timespec -- seconds )
-    [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
+    [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
-    time+ ;
 
 : timespec>unix-time ( timespec -- timestamp )
     timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
-    f time <uint> localtime ;
+    f time <time_t> localtime tm memory>struct ;
 
 : timezone-name ( -- string )
-    get-time tm-zone ;
+    get-time zone>> ;
 
 M: unix gmt-offset ( -- hours minutes seconds )
-    get-time tm-gmtoff 3600 /mod 60 /mod ;
+    get-time gmtoff>> 3600 /mod 60 /mod ;

basis/calendar/windows/windows.factor

@@ -1,15 +1,13 @@
 USING: calendar namespaces alien.c-types system
-windows.kernel32 kernel math combinators windows.errors ;
+windows.kernel32 kernel math combinators windows.errors
+accessors classes.struct ;
 IN: calendar.windows
 
 M: windows gmt-offset ( -- hours minutes seconds )
-    "TIME_ZONE_INFORMATION" <c-object>
+    TIME_ZONE_INFORMATION <struct>
     dup GetTimeZoneInformation {
         { TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
-        { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
+        { TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
-        { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
+        { TIME_ZONE_ID_STANDARD [ Bias>> ] }
-        { TIME_ZONE_ID_DAYLIGHT [
+        { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
-            [ TIME_ZONE_INFORMATION-Bias ]
-            [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
-        ] }
     } case neg 60 /mod 0 ;

basis/channels/examples/examples.factor

@@ -7,7 +7,7 @@ locals sequences ;
 IN: channels.examples
 
 : (counter) ( channel n -- )
-    [ swap to ] 2keep 1+ (counter) ;
+    [ swap to ] 2keep 1 + (counter) ;
     
 : counter ( channel -- )
     2 (counter) ;    

basis/checksums/fnv1/authors.txt

@@ -0,0 +1 @@
+Alaric Snell-Pym

basis/checksums/fnv1/fnv1-docs.factor

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

basis/checksums/fnv1/fnv1-tests.factor

@@ -0,0 +1,41 @@
+USING: checksums.fnv1 checksums strings tools.test ;
+IN: checksums.fnv1.tests
+
+! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c
+
+[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
+[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
+[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
+[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
+[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
+[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
+[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
+[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
+[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
+
+! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes.
+! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop.
+! So they may be right or wrong, but either way, them failing is cause for concern somewhere...
+
+[ 3897470310 ] [ "Hello, world!" fnv1-32 checksum-bytes ] unit-test
+[ 3985698964 ] [ "Hello, world!" fnv1a-32 checksum-bytes ] unit-test
+[ 7285062107457560934 ] [ "Hello, world!" fnv1-64 checksum-bytes ] unit-test
+[ 4094109891673226228 ] [ "Hello, world!" fnv1a-64 checksum-bytes ] unit-test
+[ 281580511747867177735318995358496831158 ] [ "Hello, world!" fnv1-128 checksum-bytes ] unit-test
+[ 303126633380056630368940439484674414572 ] [ "Hello, world!" fnv1a-128 checksum-bytes ] unit-test
+[ 104295939182568077644846978685759236849634734810631820736486253421270219742822 ] [ "Hello, world!" fnv1-256 checksum-bytes ] unit-test
+[ 9495445728692795332446740615588417456874414534608540692485745371050033741380 ] [ "Hello, world!" fnv1a-256 checksum-bytes ] unit-test
+[ 3577308325596719252093726711895047340166329831006673109476042102918876665433235513101496175651226507162015890004121912850661561110326527625579463564626958 ] [ "Hello, world!" fnv1-512 checksum-bytes ] unit-test
+[ 3577308325596719162840652138474318309664256091923081930027929425092517582111473988451078821416039944023089883981242376700859598441397004715365740906054208 ] [ "Hello, world!" fnv1a-512 checksum-bytes ] unit-test
+[ 52692754922840008511959888105094366091401994235075816792707658326855733053286986999719949898492311786648795846192078757217437117165934438286601534984230194601365788544275827382423366672856972872132009691615382991251544423521887009322211754219117294019951276080952271766377222613325328591830596794468813260226 ] [ "Hello, world!" fnv1-1024 checksum-bytes ] unit-test
+[ 52692754922840008511959888105094366091401994235075816792707658326855804920671100511873485674717442819607149127986090276849364757610838433887624184145636764448608707614141109841761957788887305179569455221243999538336208648824673027111352338809582124430199044921035232455717748500524777795242051756321605065326 ] [ "Hello, world!" fnv1a-1024 checksum-bytes ] unit-test

basis/checksums/fnv1/fnv1.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2009 Alaric Snell-Pym
+! See http://factorcode.org/license.txt for BSD license.
+USING: checksums classes.singleton kernel math math.ranges
+math.vectors sequences ;
+IN: checksums.fnv1
+
+SINGLETON: fnv1-32
+SINGLETON: fnv1a-32
+SINGLETON: fnv1-64
+SINGLETON: fnv1a-64
+SINGLETON: fnv1-128
+SINGLETON: fnv1a-128
+SINGLETON: fnv1-256
+SINGLETON: fnv1a-256
+SINGLETON: fnv1-512
+SINGLETON: fnv1a-512
+SINGLETON: fnv1-1024
+SINGLETON: fnv1a-1024
+
+CONSTANT: fnv1-32-prime 16777619
+CONSTANT: fnv1-64-prime 1099511628211
+CONSTANT: fnv1-128-prime 309485009821345068724781371
+CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211
+CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759
+CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573
+
+CONSTANT: fnv1-32-mod HEX: ffffffff
+CONSTANT: fnv1-64-mod HEX: ffffffffffffffff
+CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+CONSTANT: fnv1-32-basis HEX: 811c9dc5
+CONSTANT: fnv1-64-basis HEX: cbf29ce484222325
+CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d
+CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
+CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
+CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
+
+M: fnv1-32 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-32-basis swap
+    [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
+
+M: fnv1a-32 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-32-basis swap
+    [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
+
+
+M: fnv1-64 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-64-basis swap
+    [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
+
+M: fnv1a-64 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-64-basis swap
+    [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
+
+
+M: fnv1-128 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-128-basis swap
+    [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
+
+M: fnv1a-128 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-128-basis swap
+    [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
+
+
+M: fnv1-256 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-256-basis swap
+    [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
+
+M: fnv1a-256 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-256-basis swap
+    [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
+
+
+M: fnv1-512 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-512-basis swap
+    [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
+
+M: fnv1a-512 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-512-basis swap
+    [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
+
+
+M: fnv1-1024 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-1024-basis swap
+    [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
+
+M: fnv1a-1024 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-1024-basis swap
+    [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;

basis/checksums/fnv1/summary.txt

@@ -0,0 +1 @@
+Fowler-Noll-Vo checksum algorithm

basis/checksums/md5/md5-tests.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays checksums checksums.md5 io.encodings.binary
 io.streams.byte-array kernel math namespaces tools.test ;
-
+IN: checksums.md5.tests 
 
 [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
 [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

basis/checksums/openssl/openssl.factor

@@ -19,13 +19,13 @@ C: <openssl-checksum> openssl-checksum
 
 <PRIVATE
 
-TUPLE: evp-md-context handle ;
+TUPLE: evp-md-context < disposable handle ;
 
 : <evp-md-context> ( -- ctx )
-    "EVP_MD_CTX" <c-object>
+    evp-md-context new-disposable
-    dup EVP_MD_CTX_init evp-md-context boa ;
+    "EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
 
-M: evp-md-context dispose
+M: evp-md-context dispose*
     handle>> EVP_MD_CTX_cleanup drop ;
 
 : with-evp-md-context ( quot -- )

basis/checksums/sha/sha.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces make
+USING: accessors checksums checksums.common checksums.stream
-io.binary math.bitwise checksums checksums.common
+combinators combinators.smart fry generalizations grouping
-sbufs strings combinators.smart math.ranges fry combinators
+io.binary kernel literals locals make math math.bitwise
-accessors locals checksums.stream multiline literals
+math.ranges multiline namespaces sbufs sequences
-generalizations ;
+sequences.private splitting strings ;
 IN: checksums.sha
 
 SINGLETON: sha1
@@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 
 : prepare-M-256 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
+        [ [ 16 - ] dip nth-unsafe ]
-        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 15 - ] dip nth-unsafe s0-256 ]
-        [ [ 7 - ] dip nth ]
+        [ [ 7 - ] dip nth-unsafe ]
-        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : prepare-M-512 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
+        [ [ 16 - ] dip nth-unsafe ]
-        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 15 - ] dip nth-unsafe s0-512 ]
-        [ [ 7 - ] dip nth ]
+        [ [ 7 - ] dip nth-unsafe ]
-        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ; inline
@@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
 
 :: T1-256 ( n M H sha2 -- T1 )
-    n M nth
+    n M nth-unsafe
-    n sha2 K>> nth +
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-256 w+
+    e H nth-unsafe S1-256 w+
-    h H nth w+ ; inline
+    h H nth-unsafe w+ ; inline
 
 : T2-256 ( H -- T2 )
-    [ a swap nth S0-256 ]
+    [ a swap nth-unsafe S0-256 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 :: T1-512 ( n M H sha2 -- T1 )
-    n M nth
+    n M nth-unsafe
-    n sha2 K>> nth +
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-512 w+
+    e H nth-unsafe S1-512 w+
-    h H nth w+ ; inline
+    h H nth-unsafe w+ ; inline
 
 : T2-512 ( H -- T2 )
-    [ a swap nth S0-512 ]
+    [ a swap nth-unsafe S0-512 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 : update-H ( T1 T2 H -- )
-    h g pick exchange
+    h g pick exchange-unsafe
-    g f pick exchange
+    g f pick exchange-unsafe
-    f e pick exchange
+    f e pick exchange-unsafe
-    pick d pick nth w+ e pick set-nth
+    pick d pick nth-unsafe w+ e pick set-nth-unsafe
-    d c pick exchange
+    d c pick exchange-unsafe
-    c b pick exchange
+    c b pick exchange-unsafe
-    b a pick exchange
+    b a pick exchange-unsafe
-    [ w+ a ] dip set-nth ; inline
+    [ w+ a ] dip set-nth-unsafe ; inline
 
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
@@ -309,7 +309,7 @@ M: sha2-short checksum-block
     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 
 : seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
+    '[ _ >be ] map B{ } concat-as ;
 
 : sha1>checksum ( sha2 -- bytes )
     H>> 4 seq>byte-array ;
@@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     drop
     [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
 
-
-
 : sha1-W ( t seq -- )
     {
-        [ [ 3 - ] dip nth ]
+        [ [ 3 - ] dip nth-unsafe ]
-        [ [ 8 - ] dip nth bitxor ]
+        [ [ 8 - ] dip nth-unsafe bitxor ]
-        [ [ 14 - ] dip nth bitxor ]
+        [ [ 14 - ] dip nth-unsafe bitxor ]
-        [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+        [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
         [ ]
-    } 2cleave set-nth ;
+    } 2cleave set-nth-unsafe ;
 
 : prepare-sha1-message-schedule ( seq -- w-seq )
     4 <sliced-groups> [ be> ] map
@@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     } case ;
 
 :: inner-loop ( n H W K -- temp )
-    a H nth :> A
+    a H nth-unsafe :> A
-    b H nth :> B
+    b H nth-unsafe :> B
-    c H nth :> C
+    c H nth-unsafe :> C
-    d H nth :> D
+    d H nth-unsafe :> D
-    e H nth :> E
+    e H nth-unsafe :> E
     [
         A 5 bitroll-32
 
@@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
 
         E
 
-        n K nth
+        n K nth-unsafe
 
-        n W nth
+        n W nth-unsafe
     ] sum-outputs 32 bits ;
 
 :: process-sha1-chunk ( bytes H W K state -- )
     80 [
         H W K inner-loop
-        d H nth e H set-nth
+        d H nth-unsafe e H set-nth-unsafe
-        c H nth d H set-nth
+        c H nth-unsafe d H set-nth-unsafe
-        b H nth 30 bitroll-32 c H set-nth
+        b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
-        a H nth b H set-nth
+        a H nth-unsafe b H set-nth-unsafe
-        a H set-nth
+        a H set-nth-unsafe
     ] each
     state [ H [ w+ ] 2map ] change-H drop ; inline
 

basis/circular/circular-tests.factor

@@ -2,6 +2,7 @@
 ! See http;//factorcode.org/license.txt for BSD license
 USING: arrays kernel tools.test sequences sequences.private
 circular strings ;
+IN: circular.tests
 
 [ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
 [ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

basis/circular/circular.factor

@@ -43,16 +43,15 @@ TUPLE: growing-circular < circular length ;
 M: growing-circular length length>> ;
 
 <PRIVATE
+
 : full? ( circular -- ? )
     [ length ] [ seq>> length ] bi = ;
 
-: set-last ( elt seq -- )
-    [ length 1- ] keep set-nth ;
 PRIVATE>
 
 : push-growing-circular ( elt circular -- )
     dup full? [ push-circular ]
-    [ [ 1+ ] change-length set-last ] if ;
+    [ [ 1 + ] change-length set-last ] if ;
 
 : <growing-circular> ( capacity -- growing-circular )
     { } new-sequence 0 0 growing-circular boa ;

basis/classes/struct/prettyprint/prettyprint.factor

@@ -0,0 +1,120 @@
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types arrays assocs classes
+classes.struct combinators combinators.short-circuit continuations
+fry kernel libc make math math.parser mirrors prettyprint.backend
+prettyprint.custom prettyprint.sections see.private sequences
+slots strings summary words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+    struct-slots dup length 2 >=
+    [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+    [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+    [ class struct-slots ] [ struct-slot-values ] bi zip ;
+
+: pprint-struct-slot ( slot -- )
+    <flow \ { pprint-word
+    {
+        [ name>> text ]
+        [ c-type>> dup string? [ text ] [ pprint* ] if ]
+        [ read-only>> [ \ read-only pprint-word ] when ]
+        [ initial>> [ \ initial: pprint-word pprint* ] when* ]
+    } cleave
+    \ } pprint-word block> ;
+
+: pprint-struct ( struct -- )
+    [
+        [ \ S{ ] dip
+        [ class ]
+        [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
+        \ } (pprint-tuple)
+    ] ?pprint-tuple ;
+
+: pprint-struct-pointer ( struct -- )
+    \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
+
+PRIVATE>
+
+M: struct-class see-class*
+    <colon dup struct-definer-word pprint-word dup pprint-word
+    <block struct-slots [ pprint-struct-slot ] each
+    block> pprint-; block> ;
+
+M: struct pprint-delims
+    drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+    [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+    [ pprint-struct ]
+    [ pprint-struct-pointer ] pprint-c-object ;
+
+M: struct summary
+    [
+        dup class name>> %
+        " struct of " %
+        byte-length #
+        " bytes " %
+    ] "" make ;
+
+TUPLE: struct-mirror { object read-only } ;
+C: <struct-mirror> struct-mirror
+
+: get-struct-slot ( struct slot -- value present? )
+    over class struct-slots slot-named
+    [ name>> reader-word execute( struct -- value ) t ]
+    [ drop f f ] if* ;
+: set-struct-slot ( value struct slot -- )
+    over class struct-slots slot-named
+    [ name>> writer-word execute( value struct -- ) ]
+    [ 2drop ] if* ;
+: reset-struct-slot ( struct slot -- )
+    over class struct-slots slot-named
+    [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
+    [ drop ] if* ;
+: reset-struct-slots ( struct -- )
+    dup class struct-prototype
+    dup byte-length memcpy ;
+
+M: struct-mirror at*
+    object>> {
+        { [ over "underlying" = ] [ nip >c-ptr t ] }
+        { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
+        [ 2drop f f ]
+    } cond ;
+
+M: struct-mirror set-at
+    object>> {
+        { [ over "underlying" = ] [ 3drop ] }
+        { [ over array? ] [ swap first set-struct-slot ] }
+        [ 3drop ]
+    } cond ;
+
+M: struct-mirror delete-at
+    object>> {
+        { [ over "underlying" = ] [ 2drop ] }
+        { [ over array? ] [ swap first reset-struct-slot ] }
+        [ 2drop ]
+    } cond ;
+
+M: struct-mirror clear-assoc
+    object>> reset-struct-slots ;
+
+M: struct-mirror >alist ( mirror -- alist )
+    object>> [
+        [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
+    ] [
+        '[
+            _ struct>assoc
+            [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
+        ] [ drop { } ] recover
+    ] bi append ;
+
+M: struct make-mirror <struct-mirror> ;
+
+INSTANCE: struct-mirror assoc

basis/classes/struct/struct-docs.factor

@@ -0,0 +1,115 @@
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+    { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: (struct)
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link <struct> } " word, which initializes the struct's slots with their initial values, should be used instead." } ;
+
+{ (struct) (malloc-struct) } related-words
+
+HELP: <struct>
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
+{ $list
+{ "Struct classes cannot have a superclass defined." }
+{ "The slots of a struct must all have a type declared. The type must be a C type." } 
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: S@
+{ $syntax "S@ class alien" }
+{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } }
+{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ;
+
+{ POSTPONE: S{ POSTPONE: S@ } related-words
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+    { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+
+HELP: define-union-struct-class
+{ $values
+    { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
+
+HELP: malloc-struct
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: (malloc-struct)
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: memory>struct
+{ $values
+    { "ptr" c-ptr } { "class" class }
+    { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
+{ $subsection (struct) }
+{ $subsection (malloc-struct) }
+"Structs have literal syntax like tuples:"
+{ $subsection POSTPONE: S{ }
+"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"

basis/classes/struct/struct-tests.factor

@@ -0,0 +1,348 @@
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types alien.libraries
+alien.structs.fields alien.syntax ascii assocs byte-arrays
+classes.struct classes.tuple.private combinators
+compiler.tree.debugger compiler.units destructors
+io.encodings.utf8 io.pathnames io.streams.string kernel libc
+literals math mirrors multiline namespaces prettyprint
+prettyprint.config see sequences specialized-arrays.char
+specialized-arrays.int specialized-arrays.ushort
+struct-arrays system tools.test ;
+IN: classes.struct.tests
+
+<<
+: libfactor-ffi-tests-path ( -- string )
+    "resource:" (normalize-path)
+    {
+        { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
+        { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
+        { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
+    } cond append-path ;
+
+"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+
+"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
+>>
+
+SYMBOL: struct-test-empty
+
+[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
+[ struct-must-have-slots? ] must-fail-with
+
+STRUCT: struct-test-foo
+    { x char }
+    { y int initial: 123 }
+    { z bool } ;
+
+STRUCT: struct-test-bar
+    { w ushort initial: HEX: ffff }
+    { foo struct-test-foo } ;
+
+[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+    1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
+    {
+        [ w>> ] 
+        [ foo>> x>> ]
+        [ foo>> y>> ]
+        [ foo>> z>> ]
+    } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+[ {
+    { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
+    { { "x" "char" } 98            }
+    { { "y" "int"  } HEX: 7F00007F }
+    { { "z" "bool" } f             }
+} ] [
+    B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
+    make-mirror >alist
+] unit-test
+
+[ { { "underlying" f } } ] [
+    f struct-test-foo memory>struct
+    make-mirror >alist
+] unit-test
+
+[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
+[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
+[ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
+[ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
+[ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
+[ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
+[ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
+
+[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror { "y" "int" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror { "x" "char" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror { "nonexist" "char" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror "underlying" swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror "nonsense" swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z t } }
+    [ make-mirror clear-assoc ] keep
+] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+    { f float }
+    { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
+
+[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
+
+STRUCT: struct-test-string-ptr
+    { x char* } ;
+
+[ "hello world" ] [
+    [
+        struct-test-string-ptr <struct>
+        "hello world" utf8 malloc-string &free >>x
+        x>>
+    ] with-destructors
+] unit-test
+
+[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
+[
+    [
+        boa-tuples? off
+        c-object-pointers? off
+        struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
+    ] with-scope
+] unit-test
+
+[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
+[
+    [
+        c-object-pointers? on
+        12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
+    ] with-scope
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+    [
+        boa-tuples? on
+        c-object-pointers? off
+        struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
+    ] with-scope
+] unit-test
+
+[ "S@ struct-test-foo f" ]
+[
+    [
+        c-object-pointers? off
+        f struct-test-foo memory>struct [ pprint ] with-string-writer
+    ] with-scope
+] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+    { x char initial: 0 } { y int initial: 123 } { z bool } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+    { f float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+    T{ field-spec
+        { name "x" }
+        { offset 0 }
+        { type "char" }
+        { reader x>> }
+        { writer (>>x) }
+    }
+    T{ field-spec
+        { name "y" }
+        { offset 4 }
+        { type "int" }
+        { reader y>> }
+        { writer (>>y) }
+    }
+    T{ field-spec
+        { name "z" }
+        { offset 8 }
+        { type "bool" }
+        { reader z>> }
+        { writer (>>z) }
+    }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+    T{ field-spec
+        { name "f" }
+        { offset 0 }
+        { type "float" }
+        { reader f>> }
+        { writer (>>f) }
+    }
+    T{ field-spec
+        { name "bits" }
+        { offset 0 }
+        { type "uint" }
+        { reader bits>> }
+        { writer (>>bits) }
+    }
+} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+
+STRUCT: struct-test-equality-1
+    { x int } ;
+STRUCT: struct-test-equality-2
+    { y int } ;
+
+[ t ] [
+    [
+        struct-test-equality-1 <struct> 5 >>x
+        struct-test-equality-1 malloc-struct &free 5 >>x =
+    ] with-destructors
+] unit-test
+
+[ f ] [
+    [
+        struct-test-equality-1 <struct> 5 >>x
+        struct-test-equality-2 malloc-struct &free 5 >>y =
+    ] with-destructors
+] unit-test
+
+[ t ] [
+    [
+        struct-test-equality-1 <struct> 5 >>x
+        struct-test-equality-1 malloc-struct &free 5 >>x
+        [ hashcode ] bi@ =
+    ] with-destructors
+] unit-test
+
+STRUCT: struct-test-ffi-foo
+    { x int }
+    { y int } ;
+
+LIBRARY: f-cdecl
+FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
+
+[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
+
+STRUCT: struct-test-array-slots
+    { x int }
+    { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
+    { z int } ;
+
+[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
+
+[ t ] [
+    struct-test-array-slots <struct>
+    [ y>> [ 8 3 ] dip set-nth ]
+    [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
+] unit-test
+
+STRUCT: struct-test-optimization
+    { x { "int" 3 } } { y int } ;
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+[ t ] [
+    [ 3 struct-test-optimization <direct-struct-array> third y>> ]
+    { <tuple> <tuple-boa> memory>struct y>> } inlined?
+] unit-test
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ t ] [
+    [ struct-test-optimization memory>struct x>> second ]
+    { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
+] unit-test
+
+[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ t ] [
+    [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
+    { x>> } inlined?
+] unit-test
+
+! Test cloning structs
+STRUCT: clone-test-struct { x int } { y char[3] } ;
+
+[ 1 char-array{ 9 1 1 } ] [
+    clone-test-struct <struct>
+    1 >>x char-array{ 9 1 1 } >>y
+    clone
+    [ x>> ] [ y>> >char-array ] bi
+] unit-test
+
+[ t 1 char-array{ 9 1 1 } ] [
+    [
+        clone-test-struct malloc-struct &free
+        1 >>x char-array{ 9 1 1 } >>y
+        clone
+        [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
+    ] with-destructors
+] unit-test
+
+STRUCT: struct-that's-a-word { x int } ;
+
+: struct-that's-a-word ( -- ) "OOPS" throw ;
+
+[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+

basis/classes/struct/struct.factor

@@ -0,0 +1,323 @@
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs
+alien.structs.fields arrays byte-arrays classes classes.parser
+classes.tuple classes.tuple.parser classes.tuple.private
+combinators combinators.short-circuit combinators.smart
+definitions functors.backend fry generalizations generic.parser
+kernel kernel.private lexer libc locals macros make math math.order
+parser quotations sequences slots slots.private struct-arrays vectors
+words compiler.tree.propagation.transforms specialized-arrays.uchar ;
+FROM: slots => reader-word writer-word ;
+IN: classes.struct
+
+! struct class
+
+ERROR: struct-must-have-slots ;
+
+TUPLE: struct
+    { (underlying) c-ptr read-only } ;
+
+TUPLE: struct-slot-spec < slot-spec
+    c-type ;
+
+PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
+
+: struct-slots ( struct-class -- slots )
+    "struct-slots" word-prop ;
+
+! struct allocation
+
+M: struct >c-ptr
+    2 slot { c-ptr } declare ; inline
+
+M: struct equal?
+    {
+        [ [ class ] bi@ = ]
+        [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
+    } 2&& ; inline
+
+M: struct hashcode*
+    [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline    
+
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
+: memory>struct ( ptr class -- struct )
+    ! This is sub-optimal if the class is not literal, but gets
+    ! optimized down to efficient code if it is.
+    '[ _ boa ] call( ptr -- struct ) ; inline
+
+<PRIVATE
+: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
+    '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
+PRIVATE>
+
+: (malloc-struct) ( class -- struct )
+    [ heap-size malloc ] keep memory>struct ; inline
+
+: malloc-struct ( class -- struct )
+    [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
+
+: (struct) ( class -- struct )
+    [ heap-size (byte-array) ] keep memory>struct ; inline
+
+: <struct> ( class -- struct )
+    [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+    [
+        [ <wrapper> \ (struct) [ ] 2sequence ]
+        [
+            struct-slots
+            [ length \ ndip ]
+            [ [ name>> setter-word 1quotation ] map \ spread ] bi
+        ] bi
+    ] [ ] output>sequence ;
+
+<PRIVATE
+: pad-struct-slots ( values class -- values' class )
+    [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+    [ c-type>> c-type-getter-boxer ]
+    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+    [ c-type>> c-setter ]
+    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+    '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+    drop [ >c-ptr ] ;
+PRIVATE>
+
+M: struct-class boa>object
+    swap pad-struct-slots
+    [ <struct> ] [ struct-slots ] bi 
+    [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+    nip (reader-quot) ;
+
+M: struct-class writer-quot
+    nip (writer-quot) ;
+
+! c-types
+
+<PRIVATE
+: struct-slot-values-quot ( class -- quot )
+    struct-slots
+    [ name>> reader-word 1quotation ] map
+    \ cleave [ ] 2sequence
+    \ output>array [ ] 2sequence ;
+
+: define-inline-method ( class generic quot -- )
+    [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
+
+: (define-struct-slot-values-method) ( class -- )
+    [ \ struct-slot-values ] [ struct-slot-values-quot ] bi
+    define-inline-method ;
+
+: clone-underlying ( struct -- byte-array )
+    [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
+
+: (define-clone-method) ( class -- )
+    [ \ clone ]
+    [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
+    define-inline-method ;
+
+: slot>field ( slot -- field )
+    field-spec new swap {
+        [ name>> >>name ]
+        [ offset>> >>offset ]
+        [ c-type>> >>type ]
+        [ name>> reader-word >>reader ]
+        [ name>> writer-word >>writer ]
+    } cleave ;
+
+: define-struct-for-class ( class -- )
+    [
+        {
+            [ name>> ]
+            [ "struct-size" word-prop ]
+            [ "struct-align" word-prop ]
+            [ struct-slots [ slot>field ] map ]
+        } cleave
+        struct-type (define-struct)
+    ] [
+        {
+            [ name>> c-type ]
+            [ (unboxer-quot) >>unboxer-quot ]
+            [ (boxer-quot) >>boxer-quot ]
+            [ >>boxed-class ]
+        } cleave drop
+    ] bi ;
+
+: align-offset ( offset class -- offset' )
+    c-type-align align ;
+
+: struct-offsets ( slots -- size )
+    0 [
+        [ c-type>> align-offset ] keep
+        [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+    ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+    [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+    [ c-type>> c-type-align ] [ max ] map-reduce ;
+PRIVATE>
+
+M: struct-class c-type
+    name>> c-type ;
+
+M: struct-class c-type-align
+    "struct-align" word-prop ;
+
+M: struct-class c-type-getter
+    drop [ swap <displaced-alien> ] ;
+
+M: struct-class c-type-setter
+    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+    '[ @ swap @ _ memcpy ] ;
+
+M: struct-class c-type-boxer-quot
+    (boxer-quot) ;
+
+M: struct-class c-type-unboxer-quot
+    (unboxer-quot) ;
+
+M: struct-class heap-size
+    "struct-size" word-prop ;
+
+M: struct byte-length
+    class "struct-size" word-prop ; foldable
+
+! class definition
+
+<PRIVATE
+: make-struct-prototype ( class -- prototype )
+    [ heap-size <byte-array> ]
+    [ memory>struct ]
+    [ struct-slots ] tri
+    [
+        [ initial>> ]
+        [ (writer-quot) ] bi
+        over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+    ] each ;
+
+: (struct-methods) ( class -- )
+    [ (define-struct-slot-values-method) ]
+    [ (define-clone-method) ]
+    bi ;
+
+: (struct-word-props) ( class slots size align -- )
+    [
+        [ "struct-slots" set-word-prop ]
+        [ define-accessors ] 2bi
+    ]
+    [ "struct-size" set-word-prop ]
+    [ "struct-align" set-word-prop ] tri-curry*
+    [ tri ] 3curry
+    [ dup make-struct-prototype "prototype" set-word-prop ]
+    [ (struct-methods) ] tri ;
+
+: check-struct-slots ( slots -- )
+    [ c-type>> c-type drop ] each ;
+
+: redefine-struct-tuple-class ( class -- )
+    [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+
+: (define-struct-class) ( class slots offsets-quot -- )
+    [ 
+        [ struct-must-have-slots ]
+        [ drop redefine-struct-tuple-class ] if-empty
+    ]
+    swap '[
+        make-slots dup
+        [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+        (struct-word-props)
+    ]
+    [ drop define-struct-for-class ] 2tri ; inline
+PRIVATE>
+
+: define-struct-class ( class slots -- )
+    [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+    [ union-struct-offsets ] (define-struct-class) ;
+
+ERROR: invalid-struct-slot token ;
+
+: struct-slot-class ( c-type -- class' )
+    c-type c-type-boxed-class
+    dup \ byte-array = [ drop \ c-ptr ] when ;
+
+: <struct-slot-spec> ( name c-type attributes -- slot-spec )
+    [ struct-slot-spec new ] 3dip
+    [ >>name ]
+    [ [ >>c-type ] [ struct-slot-class >>class ] bi ]
+    [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
+
+<PRIVATE
+: scan-c-type ( -- c-type )
+    scan dup "{" = [ drop \ } parse-until >array ] when ;
+
+: parse-struct-slot ( -- slot )
+    scan scan-c-type \ } parse-until <struct-slot-spec> ;
+    
+: parse-struct-slots ( slots -- slots' more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot over push t ] }
+        [ invalid-struct-slot ]
+    } case ;
+
+: parse-struct-definition ( -- class slots )
+    CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+PRIVATE>
+
+SYNTAX: STRUCT:
+    parse-struct-definition define-struct-class ;
+SYNTAX: UNION-STRUCT:
+    parse-struct-definition define-union-struct-class ;
+
+SYNTAX: S{
+    scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+
+SYNTAX: S@
+    scan-word scan-object swap memory>struct parsed ;
+
+! functor support
+
+<PRIVATE
+: scan-c-type` ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+: parse-struct-slot` ( accum -- accum )
+    scan-string-param scan-c-type` \ } parse-until
+    [ <struct-slot-spec> over push ] 3curry over push-all ;
+
+: parse-struct-slots` ( accum -- accum more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot` t ] }
+        [ invalid-struct-slot ]
+    } case ;
+PRIVATE>
+
+FUNCTOR-SYNTAX: STRUCT:
+    scan-param parsed
+    [ 8 <vector> ] over push-all
+    [ parse-struct-slots` ] [ ] while
+    [ >array define-struct-class ] over push-all ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "classes.struct.prettyprint" require ] when

basis/cocoa/application/application.factor

@@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 
-: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+CONSTANT: NSAnyEventMask HEX: ffffffff
 
 FUNCTION: void NSBeep ( ) ;
 

basis/cocoa/callbacks/callbacks.factor

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

basis/cocoa/cocoa-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.tests
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 compiler kernel namespaces cocoa.classes tools.test memory
 compiler.units math core-graphics.types ;
+IN: cocoa.tests
 
 CLASS: {
     { +superclass+ "NSObject" }

basis/cocoa/cocoa.factor

@@ -60,6 +60,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
         "NSOpenGLPixelFormat"
         "NSOpenGLView"
         "NSOpenPanel"
+        "NSPanel"
         "NSPasteboard"
         "NSPropertyListSerialization"
         "NSResponder"

basis/cocoa/enumeration/enumeration.factor

@@ -1,27 +1,28 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cocoa cocoa.types alien.c-types locals math
+USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
-sequences vectors fry libc destructors
+locals math sequences vectors fry libc destructors ;
-specialized-arrays.direct.alien ;
 IN: cocoa.enumeration
 
+<< "id" require-c-array >>
+
 CONSTANT: NS-EACH-BUFFER-SIZE 16
 
 : with-enumeration-buffers ( quot -- )
     '[
-        "NSFastEnumerationState" malloc-object &free
+        NSFastEnumerationState malloc-struct &free
         NS-EACH-BUFFER-SIZE "id" malloc-array &free
         NS-EACH-BUFFER-SIZE
         @
     ] with-destructors ; inline
 
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
-    object state stackbuf count -> countByEnumeratingWithState:objects:count:
+    object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
-    dup 0 = [ drop ] [
+    items-count 0 = [
-        state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
+        state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
-        swap <direct-void*-array> quot each
+        items-count iota [ items nth quot call ] each
         object quot state stackbuf count (NSFastEnumeration-each)
-    ] if ; inline recursive
+    ] unless ; inline recursive
 
 : NSFastEnumeration-each ( object quot -- )
     [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline

basis/cocoa/messages/messages.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-continuations combinators compiler compiler.alien stack-checker kernel
+classes.struct continuations combinators compiler compiler.alien
-math namespaces make quotations sequences strings words
+stack-checker kernel math namespaces make quotations sequences
-cocoa.runtime io macros memoize io.encodings.utf8 effects libc
+strings words cocoa.runtime io macros memoize io.encodings.utf8
-libc.private lexer init core-foundation fry generalizations
+effects libc libc.private lexer init core-foundation fry
-specialized-arrays.direct.alien ;
+generalizations specialized-arrays.alien ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize
     bi ;
 
 : <super> ( receiver -- super )
-    "objc-super" <c-object> [
+    [ ] [ object_getClass class_getSuperclass ] bi
-        [ dup object_getClass class_getSuperclass ] dip
+    objc-super <struct-boa> ;
-        set-objc-super-class
-    ] keep
-    [ set-objc-super-receiver ] keep ;
 
 TUPLE: selector name object ;
 
@@ -158,12 +155,16 @@ objc>alien-types get [ swap ] assoc-map
 } case
 assoc-union alien>objc-types set-global
 
+: internal-cocoa-type? ( c-type -- ? )
+    [ "?" = ] [ first CHAR: _ = ] bi or ;
+
+: warn-c-type ( c-type -- )
+    dup internal-cocoa-type?
+    [ drop ] [ "Warning: no such C type: " write print ] if ;
+
 : objc-struct-type ( i string -- ctype )
     [ CHAR: = ] 2keep index-from swap subseq
-    dup c-types get key? [
+    dup c-types get key? [ warn-c-type "void*" ] unless ;
-        "Warning: no such C type: " write dup print
-        drop "void*"
-    ] unless ;
 
 ERROR: no-objc-type name ;
 
@@ -172,7 +173,7 @@ ERROR: no-objc-type name ;
     [ ] [ no-objc-type ] ?if ;
 
 : (parse-objc-type) ( i string -- ctype )
-    [ [ 1+ ] dip ] [ nth ] 2bi {
+    [ [ 1 + ] dip ] [ nth ] 2bi {
         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
         { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
         { [ dup CHAR: { = ] [ drop objc-struct-type ] }

basis/cocoa/plists/plists-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.plists.tests
 USING: tools.test cocoa.plists colors kernel hashtables
 core-foundation.utilities core-foundation destructors
 assocs cocoa.enumeration ;
+IN: cocoa.plists.tests
 
 [
     [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
@@ -37,4 +37,4 @@ assocs cocoa.enumeration ;
     [ 3.5 ] [
         3.5 >cf &CFRelease plist>
     ] unit-test
-] with-destructors
+] with-destructors

basis/cocoa/runtime/runtime.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
 IN: cocoa.runtime
 
 TYPEDEF: void* SEL
@@ -17,9 +17,9 @@ TYPEDEF: void* Class
 TYPEDEF: void* Method
 TYPEDEF: void* Protocol
 
-C-STRUCT: objc-super
+STRUCT: objc-super
-    { "id" "receiver" }
+    { receiver id }
-    { "Class" "class" } ;
+    { class Class } ;
 
 CONSTANT: CLS_CLASS        HEX: 1
 CONSTANT: CLS_META         HEX: 2

basis/cocoa/types/types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax combinators kernel layouts
-core-graphics.types ;
+classes.struct core-graphics.types ;
 IN: cocoa.types
 
 TYPEDEF: long NSInteger
@@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize
 TYPEDEF: CGRect NSRect
 TYPEDEF: NSRect _NSRect
 
-C-STRUCT: NSRange
+STRUCT: NSRange
-    { "NSUInteger" "location" }
+    { location NSUInteger }
-    { "NSUInteger" "length" } ;
+    { length NSUInteger } ;
 
 TYPEDEF: NSRange _NSRange
 
@@ -27,13 +27,11 @@ TYPEDEF: int long32
 TYPEDEF: uint ulong32
 TYPEDEF: void* unknown_type
 
-: <NSRange> ( length location -- size )
+: <NSRange> ( location length -- size )
-    "NSRange" <c-object>
+    NSRange <struct-boa> ;
-    [ set-NSRange-length ] keep
-    [ set-NSRange-location ] keep ;
 
-C-STRUCT: NSFastEnumerationState
+STRUCT: NSFastEnumerationState
-    { "ulong" "state" }
+    { state ulong }
-    { "id*" "itemsPtr" }
+    { itemsPtr id* }
-    { "ulong*" "mutationsPtr" }
+    { mutationsPtr ulong* }
-    { "ulong[5]" "extra" } ;
+    { extra ulong[5] } ;

basis/cocoa/views/views.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: specialized-arrays.int arrays kernel math namespaces make
+USING: arrays kernel math namespaces make
 cocoa cocoa.messages cocoa.classes core-graphics
 core-graphics.types sequences continuations accessors ;
 IN: cocoa.views
@@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222
 : mouse-location ( view event -- loc )
     [
         -> locationInWindow f -> convertPoint:fromView:
-        [ CGPoint-x ] [ CGPoint-y ] bi
+        [ x>> ] [ y>> ] bi
     ] [ drop -> frame CGRect-h ] 2bi
     swap - [ >integer ] bi@ 2array ;

basis/cocoa/windows/windows-docs.factor

@@ -2,11 +2,11 @@ USING: help.markup help.syntax ;
 IN: cocoa.windows
 
 HELP: <NSWindow>
-{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
+{ $values { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "class" "an Objective-C class" } { "window" "an " { $snippet "NSWindow" } } }
 { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ;
 
 HELP: <ViewWindow>
-{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
+{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "window" "an " { $snippet "NSWindow" } } }
 { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ;
 
 ARTICLE: "cocoa-window-utils" "Cocoa window utilities"

basis/cocoa/windows/windows.factor

@@ -4,36 +4,37 @@ USING: arrays kernel math cocoa cocoa.messages cocoa.classes
 sequences math.bitwise ;
 IN: cocoa.windows
 
+! Window styles
 CONSTANT: NSBorderlessWindowMask     0
 CONSTANT: NSTitledWindowMask         1
 CONSTANT: NSClosableWindowMask       2
 CONSTANT: NSMiniaturizableWindowMask 4
 CONSTANT: NSResizableWindowMask      8
 
+! Additional panel-only styles 
+CONSTANT: NSUtilityWindowMask       16
+CONSTANT: NSDocModalWindowMask      64
+CONSTANT: NSNonactivatingPanelMask 128
+CONSTANT: NSHUDWindowMask    HEX: 1000
+
 CONSTANT: NSBackingStoreRetained    0
 CONSTANT: NSBackingStoreNonretained 1
 CONSTANT: NSBackingStoreBuffered    2
 
-: standard-window-type ( -- n )
+: <NSWindow> ( rect style class -- window )
-    {
+    [ -> alloc ] curry 2dip NSBackingStoreBuffered 1
-        NSTitledWindowMask
-        NSClosableWindowMask
-        NSMiniaturizableWindowMask
-        NSResizableWindowMask
-    } flags ; inline
-
-: <NSWindow> ( rect -- window )
-    NSWindow -> alloc swap
-    standard-window-type NSBackingStoreBuffered 1
     -> initWithContentRect:styleMask:backing:defer: ;
 
-: <ViewWindow> ( view rect -- window )
+: class-for-style ( style -- NSWindow/NSPanel )
-    <NSWindow> [ swap -> setContentView: ] keep
+    HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
+
+: <ViewWindow> ( view rect style -- window )
+    dup class-for-style <NSWindow> [ swap -> setContentView: ] keep
     dup dup -> contentView -> setInitialFirstResponder:
     dup 1 -> setAcceptsMouseMovedEvents:
     dup 0 -> setReleasedWhenClosed: ;
 
 : window-content-rect ( window -- rect )
-    [ NSWindow ] dip
+    dup -> class swap
     [ -> frame ] [ -> styleMask ] bi
     -> contentRectForFrameRect:styleMask: ;

basis/colors/constants/constants.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs math math.parser memoize
+USING: kernel assocs math math.parser memoize io.encodings.utf8
-io.encodings.ascii io.files lexer parser
+io.files lexer parser colors sequences splitting
-colors sequences splitting combinators.smart ascii ;
+combinators.smart ascii ;
 IN: colors.constants
 
 <PRIVATE
@@ -19,7 +19,7 @@ IN: colors.constants
     [ parse-color ] H{ } map>assoc ;
 
 MEMO: rgb.txt ( -- assoc )
-    "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
+    "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
 
 PRIVATE>
 

basis/colors/hsv/hsv-tests.factor

@@ -1,5 +1,5 @@
-IN: colors.hsv.tests
 USING: accessors kernel colors colors.hsv tools.test math ;
+IN: colors.hsv.tests
 
 : hsv>rgb ( h s v -- r g b )
     [ 360 * ] 2dip
@@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ;
 [ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
 [ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
 
-[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
+[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test

basis/columns/columns-tests.factor

@@ -1,5 +1,5 @@
-IN: columns.tests
 USING: columns sequences kernel namespaces arrays tools.test math ;
+IN: columns.tests
 
 ! Columns
 { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

basis/combinators/short-circuit/short-circuit-docs.factor

@@ -1,62 +1,46 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax io.streams.string quotations
-math ;
+math kernel ;
 IN: combinators.short-circuit
 
 HELP: 0&&
-{ $values
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
 
 HELP: 0||
-{ $values
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if any quotation in the sequence returns true." } ;
 
 HELP: 1&&
-{ $values
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
 
 HELP: 1||
-{ $values
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
-     { "quot" quotation } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
 
 HELP: 2&&
-{ $values
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
 
 HELP: 2||
-{ $values
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
-     { "quot" quotation } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
 
 HELP: 3&&
-{ $values
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
 
 HELP: 3||
-{ $values
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
-     { "quot" quotation } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
 
 HELP: n&&
 { $values
-     { "quots" "a sequence of quotations" } { "N" integer }
+     { "quots" "a sequence of quotations" } { "n" integer }
      { "quot" quotation } }
-{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ;
 
 HELP: n||
 { $values

basis/combinators/short-circuit/short-circuit-tests.factor

@@ -1,32 +1,25 @@
-
 USING: kernel math tools.test combinators.short-circuit ;
-
 IN: combinators.short-circuit.tests
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
+[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test
+[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test
 
-: must-be-t ( in -- ) [ t ] swap unit-test ;
+[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test
-: must-be-f ( in -- ) [ f ] swap unit-test ;
+[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test
+[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test
+[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test
 
-[       { [ 1 ] [ 2 ] [ 3 ] }           0&&  3 = ] must-be-t
+: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ;
-[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    1&&  5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
 
-[       { [ 1 ] [ f ] [ 3 ] } 0&&  3 = ]          must-be-f
+[ f ] [ 3 compiled-&& ] unit-test
-[ 3     { [ 0 > ] [ even? ] [ 2 + ] } 1&& ]       must-be-f
+[ 4 ] [ 2 compiled-&& ] unit-test
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t
-
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ]       must-be-t
-
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ]  must-be-t
-
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+[ 30 ] [ 10 20 compiled-|| ] unit-test
+[ 2 ] [ 1 1 compiled-|| ] unit-test

basis/combinators/short-circuit/short-circuit.factor

@@ -12,10 +12,17 @@ MACRO:: n&& ( quots n -- quot )
     n '[ _ nnip ] suffix 1array
     [ cond ] 3append ;
 
-MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
+<PRIVATE
-MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
+
-MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
+: unoptimized-&& ( quots quot -- ? )
-MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
+    [ [ call dup ] ] dip call [ nip ] prepose [ f ] 2dip all? swap and ; inline
+
+PRIVATE>
+
+: 0&& ( quots -- ? ) [ ] unoptimized-&& ;
+: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
+: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
+: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
 
 MACRO:: n|| ( quots n -- quot )
     [ f ] quots [| q |
@@ -27,7 +34,14 @@ MACRO:: n|| ( quots n -- quot )
     n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
     [ cond ] 3append ;
 
-MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
+<PRIVATE
-MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
+
-MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
+: unoptimized-|| ( quots quot -- ? )
-MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
+    [ [ call ] ] dip call map-find drop ; inline
+
+PRIVATE>
+
+: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
+: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
+: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
+: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;

basis/combinators/short-circuit/smart/smart-tests.factor

@@ -1,32 +1,18 @@
-
 USING: kernel math tools.test combinators.short-circuit.smart ;
-
 IN: combinators.short-circuit.smart.tests
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] unit-test
+[ t ] [ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
 
-: must-be-t ( in -- ) [ t ] swap unit-test ;
+[ f ] [       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          unit-test
-: must-be-f ( in -- ) [ f ] swap unit-test ;
+[ f ] [ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
 
-[       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] must-be-t
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       unit-test
-[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
 
-[       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          must-be-f
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  unit-test
-[ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
-
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       must-be-t
-
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  must-be-t
-
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test