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

core/alien/alien-tests.factor

@@ -1,7 +1,7 @@
 IN: alien.tests
 USING: alien alien.accessors byte-arrays arrays kernel
 kernel.private namespaces tools.test sequences libc math system
-prettyprint ;
+prettyprint layouts ;
 
 [ t ] [ -1 <alien> alien-address 0 > ] unit-test
 

core/alien/c-types/c-types.factor

@@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays
 generator.registers assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
-system compiler.units io.files io.encodings.binary ;
+layouts system compiler.units io.files io.encodings.binary ;
 IN: alien.c-types
 
 DEFER: <int>

core/alien/compiler/compiler.factor

@@ -6,7 +6,7 @@ inference.state inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
 kernel.private threads continuations.private libc combinators
-compiler.errors continuations ;
+compiler.errors continuations layouts ;
 IN: alien.compiler
 
 ! Common protocol for alien-invoke/alien-callback/alien-indirect

core/bootstrap/image/image.factor

@@ -191,7 +191,9 @@ M: bignum '
 M: fixnum '
     #! When generating a 32-bit image on a 64-bit system,
     #! some fixnums should be bignums.
-    dup most-negative-fixnum most-positive-fixnum between?
+    dup
+    bootstrap-most-negative-fixnum
+    bootstrap-most-positive-fixnum between?
     [ tag-fixnum ] [ >bignum ' ] if ;
 
 ! Floats

core/classes/classes-docs.factor

@@ -7,11 +7,6 @@ IN: classes
 ARTICLE: "builtin-classes" "Built-in classes"
 "Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
 $nl
-"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
-"Built-in type numbers can be converted to classes, and vice versa:"
-{ $subsection type>class }
-{ $subsection type-number }
 "The set of built-in classes is a class:"
 { $subsection builtin-class }
 { $subsection builtin-class? }

core/cpu/x86/32/32.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
 cpu.architecture kernel kernel.private math namespaces sequences
-generator.registers generator.fixup generator system
+generator.registers generator.fixup generator system layouts
 alien.compiler combinators command-line
 compiler compiler.units io vocabs.loader ;
 IN: cpu.x86.32

core/cpu/x86/64/64.factor

@@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
 namespaces sequences generator.registers generator.fixup system
-alien alien.accessors alien.compiler alien.structs slots
+layouts alien alien.accessors alien.compiler alien.structs slots
 splitting assocs ;
 IN: cpu.x86.64
 

core/cpu/x86/assembler/assembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
-words system ;
+words system layouts ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.

core/generator/fixup/fixup.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs hashtables
 kernel kernel.private math namespaces sequences words
-quotations strings alien system combinators math.bitfields
+quotations strings alien layouts system combinators
-words.private cpu.architecture ;
+math.bitfields words.private cpu.architecture ;
 IN: generator.fixup
 
 : no-stack-frame -1 ; inline

core/inference/class/class-tests.factor

@@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
 sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
 slots.private combinators definitions compiler.units
-system ;
+system layouts ;
 
 ! Make sure these compile even though this is invalid code
 [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test

core/io/files/files-docs.factor

@@ -44,6 +44,8 @@ ARTICLE: "directories" "Directories"
 { $subsection make-directories } ;
 
 ARTICLE: "fs-meta" "File meta-data"
+{ $subsection file-info }
+{ $subsection link-info }
 { $subsection exists? }
 { $subsection directory? }
 { $subsection file-length }
@@ -114,6 +116,25 @@ HELP: file-name
     { $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
 } ;
 
+! need a $class-description file-info
+
+HELP: file-info
+  { $values { "path" "a pathname string" }
+            { "info" "a file-info tuple" } }
+  { $description "Queries the file system for meta data. "
+                 "If path refers to a symbolic link, it is followed."
+                 "If the file does not exist, an exception is thrown." } ;
+! need a see also to link-info
+
+HELP: link-info
+  { $values { "path" "a pathname string" }
+            { "info" "a file-info tuple" } }
+  { $description "Queries the file system for meta data. "
+                 "If path refers to a symbolic link, information about "
+                 "the symbolic link itself is returned."
+                 "If the file does not exist, an exception is thrown." } ;
+! need a see also to file-info
+
 HELP: <file-reader>
 { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
     { "stream" "an input stream" } }

core/kernel/kernel-docs.factor

@@ -127,12 +127,22 @@ ARTICLE: "conditionals" "Conditionals and logic"
 { $see-also "booleans" "bitwise-arithmetic" both? either? } ;
 
 ARTICLE: "equality" "Equality and comparison testing"
-"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object, or you can test if two objects are equal in some sense, usually by being instances of the same class, and having equal slot values. Both notions of equality are equality relations in the mathematical sense."
+"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
+$nl
+"Identity comparison:"
 { $subsection eq? }
+"Value comparison:"
 { $subsection = }
+"Generic words for custom value comparison methods:"
+{ $subsection equal? }
 "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
 { $subsection <=> }
 { $subsection compare }
+"Utilities for comparing objects:"
+{ $subsection after? }
+{ $subsection before? }
+{ $subsection after=? }
+{ $subsection before=? }
 "An object can be cloned; the clone has distinct identity but equal value:"
 { $subsection clone } ;
 
@@ -225,21 +235,18 @@ HELP: equal?
 { $contract
     "Tests if two objects are equal."
     $nl
-    "Method definitions should ensure that this is an equality relation:"
+    "User code should call " { $link = } " instead; that word first tests the case where the objects are " { $link eq? } ", and so by extension, methods defined on " { $link equal? } " assume they are never called on " { $link eq? } " objects."
+    $nl
+    "Method definitions should ensure that this is an equality relation, modulo the assumption that the two objects are not " { $link eq? } ". That is, for any three non-" { $link eq? } " objects " { $snippet "a" } ", " { $snippet "b" } " and " { $snippet "c" } ", we must have:"
     { $list
-        { $snippet "a = a" }
         { { $snippet "a = b" } " implies " { $snippet "b = a" } }
         { { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } }
     }
-    "While user code can define methods for this generic word, it should not call it directly, since it does not handle the case where the two references point to the same object."
 }
 { $examples
-    "The most common reason for defining a method for this generic word to ensure that instances of a specific tuple class are only ever equal to themselves, overriding the default implementation which checks slot values for equality."
+    "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
     { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
-    "Note that with the above definition, calling " { $link equal? } " directly will give unexpected results:"
+    "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
-    { $unchecked-example "T{ foo } dup equal? ." "f" }
-    { $unchecked-example "T{ foo } dup clone equal? ." "f" }
-    "As documented above, " { $link = } " should be called instead:"
     { $unchecked-example "T{ foo } dup = ." "t" }
     { $unchecked-example "T{ foo } dup clone = ." "f" }
 } ;

core/layouts/layouts-docs.factor

@@ -1,5 +1,7 @@
-USING: layouts generic help.markup help.syntax kernel math
+USING: generic help.markup help.syntax kernel math
-memory namespaces sequences kernel.private classes ;
+memory namespaces sequences kernel.private classes
+sequences.private ;
+IN: layouts
 
 HELP: tag-bits
 { $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
@@ -35,3 +37,88 @@ HELP: most-positive-fixnum
 
 HELP: most-negative-fixnum
 { $values { "n" "smallest negative integer representable by a fixnum" } } ;
+
+HELP: bootstrap-first-bignum
+{ $values { "n" "smallest positive integer not representable by a fixnum" } }
+{ $description "Outputs the value for the target architecture when bootstrapping." } ;
+
+HELP: bootstrap-most-positive-fixnum
+{ $values { "n" "largest positive integer representable by a fixnum" } } 
+{ $description "Outputs the value for the target architecture when bootstrapping." } ;
+
+HELP: bootstrap-most-negative-fixnum
+{ $values { "n" "smallest negative integer representable by a fixnum" } } 
+{ $description "Outputs the value for the target architecture when bootstrapping." } ;
+
+HELP: cell
+{ $values { "n" "a positive integer" } }
+{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
+
+HELP: cells
+{ $values { "m" integer } { "n" integer } }
+{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
+
+HELP: cell-bits
+{ $values { "n" integer } }
+{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
+
+HELP: bootstrap-cell
+{ $values { "n" "a positive integer" } }
+{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
+
+HELP: bootstrap-cells
+{ $values { "m" integer } { "n" integer } }
+{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
+
+HELP: bootstrap-cell-bits
+{ $values { "n" integer } }
+{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
+
+ARTICLE: "layouts-types" "Type numbers"
+"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
+{ $subsection type }
+"Built-in type numbers can be converted to classes, and vice versa:"
+{ $subsection type>class }
+{ $subsection type-number }
+{ $subsection num-types }
+{ $see-also "builtin-classes" } ;
+
+ARTICLE: "layouts-tags" "Tagged pointers"
+"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
+$nl
+"Getting the tag of an object:"
+{ $link tag }
+"Words for working with tagged pointers:"
+{ $subsection tag-bits }
+{ $subsection num-tags }
+{ $subsection tag-mask }
+{ $subsection tag-number }
+"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;
+
+ARTICLE: "layouts-limits" "Sizes and limits"
+"Processor cell size:"
+{ $subsection cell }
+{ $subsection cells }
+{ $subsection cell-bits }
+"Range of integers representable by " { $link fixnum } "s:"
+{ $subsection most-negative-fixnum }
+{ $subsection most-positive-fixnum }
+"Maximum array size:"
+{ $subsection max-array-capacity } ;
+
+ARTICLE: "layouts-bootstrap" "Bootstrap support"
+"Bootstrap support:"
+{ $subsection bootstrap-cell }
+{ $subsection bootstrap-cells }
+{ $subsection bootstrap-cell-bits }
+{ $subsection bootstrap-most-negative-fixnum }
+{ $subsection bootstrap-most-positive-fixnum } ;
+
+ARTICLE: "layouts" "VM memory layouts"
+"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation."
+{ $subsection "layouts-types" }
+{ $subsection "layouts-tags" }
+{ $subsection "layouts-limits" }
+{ $subsection "layouts-bootstrap" } ;
+
+ABOUT: "layouts"

core/layouts/layouts-tests.factor

@@ -0,0 +1,5 @@
+IN: system.tests
+USING: layouts math tools.test ;
+
+[ t ] [ cell integer? ] unit-test
+[ t ] [ bootstrap-cell integer? ] unit-test

core/layouts/layouts.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math words kernel assocs system classes ;
+USING: namespaces math words kernel assocs classes
+kernel.private ;
 IN: layouts
 
 SYMBOL: tag-mask
@@ -24,8 +25,23 @@ SYMBOL: type-numbers
 : tag-fixnum ( n -- tagged )
     tag-bits get shift ;
 
+: cell ( -- n ) 7 getenv ; foldable
+
+: cells ( m -- n ) cell * ; inline
+
+: cell-bits ( -- n ) 8 cells ; inline
+
+: bootstrap-cell \ cell get cell or ; inline
+
+: bootstrap-cells bootstrap-cell * ; inline
+
+: bootstrap-cell-bits 8 bootstrap-cells ; inline
+
+: (first-bignum) ( m -- n )
+    tag-bits get - 1 - 2^ ;
+
 : first-bignum ( -- n )
-    bootstrap-cell-bits tag-bits get - 1 - 2^ ;
+    cell-bits (first-bignum) ;
 
 : most-positive-fixnum ( -- n )
     first-bignum 1- ;
@@ -33,6 +49,15 @@ SYMBOL: type-numbers
 : most-negative-fixnum ( -- n )
     first-bignum neg ;
 
+: bootstrap-first-bignum ( -- n )
+    bootstrap-cell-bits (first-bignum) ;
+
+: bootstrap-most-positive-fixnum ( -- n )
+    bootstrap-first-bignum 1- ;
+
+: bootstrap-most-negative-fixnum ( -- n )
+    bootstrap-first-bignum neg ;
+
 M: bignum >integer
     dup most-negative-fixnum most-positive-fixnum between?
     [ >fixnum ] when ;

core/system/system-docs.factor

@@ -15,10 +15,6 @@ ARTICLE: "os" "System interface"
 { $subsection wince? }
 "Processor detection:"
 { $subsection cpu }
-"Processor cell size:"
-{ $subsection cell }
-{ $subsection cells }
-{ $subsection cell-bits }
 "Reading environment variables:"
 { $subsection os-env }
 { $subsection os-envs }
@@ -114,7 +110,15 @@ HELP: os-envs
 }
 { $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
 
-{ os-env os-envs } related-words
+HELP: set-os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Replaces the current set of environment variables." }
+{ $notes
+    "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+{ os-env os-envs set-os-envs } related-words
 
 HELP: win32?
 { $values { "?" "a boolean" } }
@@ -135,27 +139,3 @@ HELP: vm
 HELP: unix?
 { $values { "?" "a boolean" } }
 { $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;
-
-HELP: cell
-{ $values { "n" "a positive integer" } }
-{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
-
-HELP: cells
-{ $values { "m" integer } { "n" integer } }
-{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
-
-HELP: cell-bits
-{ $values { "n" integer } }
-{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
-
-HELP: bootstrap-cell
-{ $values { "n" "a positive integer" } }
-{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
-
-HELP: bootstrap-cells
-{ $values { "m" integer } { "n" integer } }
-{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
-
-HELP: bootstrap-cell-bits
-{ $values { "n" integer } }
-{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;

core/system/system-tests.factor

@@ -1,9 +1,6 @@
 USING: math tools.test system prettyprint namespaces kernel ;
 IN: system.tests
 
-[ t ] [ cell integer? ] unit-test
-[ t ] [ bootstrap-cell integer? ] unit-test
-
 wince? [
     [ ] [ os-envs . ] unit-test
 ] unless

core/system/system.factor

@@ -2,13 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: system
 USING: kernel kernel.private sequences math namespaces
-splitting assocs system.private ;
+splitting assocs system.private layouts ;
-
-: cell ( -- n ) 7 getenv ; foldable
-
-: cells ( m -- n ) cell * ; inline
-
-: cell-bits ( -- n ) 8 cells ; inline
 
 : cpu ( -- cpu ) 8 getenv ; foldable
 
@@ -51,12 +45,6 @@ splitting assocs system.private ;
 : solaris? ( -- ? )
     os "solaris" = ;
 
-: bootstrap-cell \ cell get cell or ; inline
-
-: bootstrap-cells bootstrap-cell * ; inline
-
-: bootstrap-cell-bits 8 bootstrap-cells ; inline
-
 : os-envs ( -- assoc )
     (os-envs) [ "=" split1 ] H{ } map>assoc ;
 

extra/alarms/alarms-tests.factor

@@ -1,6 +1,6 @@
 IN: alarms.tests
-USING: alarms kernel calendar sequences tools.test threads
+USING: alarms alarms.private kernel calendar sequences
-concurrency.count-downs ;
+tools.test threads concurrency.count-downs ;
 
 [ ] [
     1 <count-down>
@@ -15,3 +15,5 @@ concurrency.count-downs ;
         [ resume ] curry instant later drop
     ] "test" suspend drop
 ] unit-test
+
+\ alarm-thread-loop must-infer

extra/alarms/alarms.factor

@@ -38,7 +38,7 @@ SYMBOL: alarm-thread
 
 : call-alarm ( alarm -- )
     dup alarm-entry box> drop
-    dup alarm-quot try
+    dup alarm-quot "Alarm execution" spawn drop
     dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
 
 : (trigger-alarms) ( alarms now -- )
@@ -62,8 +62,7 @@ SYMBOL: alarm-thread
 : alarm-thread-loop ( -- )
     alarms get-global
     dup next-alarm sleep-until
-    dup trigger-alarms
+    trigger-alarms ;
-    alarm-thread-loop ;
 
 : cancel-alarms ( alarms -- )
     [
@@ -72,7 +71,7 @@ SYMBOL: alarm-thread
 
 : init-alarms ( -- )
     alarms global [ cancel-alarms <min-heap> ] change-at
-    [ alarm-thread-loop ] "Alarms" spawn
+    [ alarm-thread-loop t ] "Alarms" spawn-server
     alarm-thread set-global ;
 
 [ init-alarms ] "alarms" add-init-hook

extra/benchmark/crc32/crc32.factor

@@ -1,10 +1,10 @@
-USING: io.crc32 io.files kernel math ;
+USING: io.crc32 io.encodings.ascii io.files kernel math ;
 IN: benchmark.crc32
 
 : crc32-primes-list ( -- )
     10 [
         "extra/math/primes/list/list.factor" resource-path
-        file-contents crc32 drop
+        ascii file-contents crc32 drop
     ] times ;
 
 MAIN: crc32-primes-list

extra/benchmark/mandel/mandel.factor

@@ -1,7 +1,7 @@
 IN: benchmark.mandel
-USING: arrays io kernel math namespaces sequences strings sbufs
+USING: arrays io kernel math namespaces sequences
-math.functions math.parser io.files colors.hsv
+byte-arrays byte-vectors math.functions math.parser io.files
-io.encodings.ascii ;
+colors.hsv io.encodings.binary ;
 
 : max-color 360 ; inline
 : zoom-fact 0.8 ; inline
@@ -54,18 +54,18 @@ SYMBOL: cols
 : ppm-header ( w h -- )
     "P6\n" % swap # " " % # "\n255\n" % ;
 
-: sbuf-size width height * 3 * 100 + ;
+: buf-size width height * 3 * 100 + ;
 
-: mandel ( -- string )
+: mandel ( -- data )
     [
-        sbuf-size <sbuf> building set
+        buf-size <byte-vector> building set
         width height ppm-header
         nb-iter max-color min <color-map> cols set
         render
-        building get >string
+        building get >byte-array
     ] with-scope ;
 
 : mandel-main ( -- )
-    mandel "mandel.ppm" temp-file ascii set-file-contents ;
+    mandel "mandel.ppm" temp-file binary set-file-contents ;
 
 MAIN: mandel-main

extra/benchmark/random/random.factor

@@ -1,10 +1,10 @@
-USING: io.files random math.parser io math ;
+USING: io.files io.encodings.ascii random math.parser io math ;
 IN: benchmark.random
 
 : random-numbers-path "random-numbers.txt" temp-file ;
 
 : write-random-numbers ( n -- )
-    random-numbers-path [
+    random-numbers-path ascii [
         [ 200 random 100 - number>string print ] times
     ] with-file-writer ;
 

extra/benchmark/raytracer/raytracer.factor

@@ -3,7 +3,7 @@
 
 USING: float-arrays compiler generic io io.files kernel math
 math.functions math.vectors math.parser namespaces sequences
-sequences.private words io.encodings.ascii ;
+sequences.private words io.encodings.binary ;
 IN: benchmark.raytracer
 
 ! parameters
@@ -167,9 +167,9 @@ DEFER: create ( level c r -- scene )
     levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
         size size pgm-header
         [ [ oversampling sq / pgm-pixel ] each ] each
-    ] "" make ;
+    ] B{ } make ;
 
 : raytracer-main
-    run "raytracer.pnm" temp-file ascii set-file-contents ;
+    run "raytracer.pnm" temp-file binary set-file-contents ;
 
 MAIN: raytracer-main

extra/benchmark/sort/sort.factor

@@ -1,8 +1,10 @@
 USING: kernel sequences sorting benchmark.random math.parser
-io.files ;
+io.files io.encodings.ascii ;
 IN: benchmark.sort
 
 : sort-benchmark
-    random-numbers-path file-lines [ string>number ] map natural-sort drop ;
+    random-numbers-path
+    ascii file-lines [ string>number ] map
+    natural-sort drop ;
 
 MAIN: sort-benchmark

extra/combinators/cleave/cleave-docs.factor

@@ -0,0 +1,82 @@
+
+USING: kernel quotations help.syntax help.markup ;
+
+IN: combinators.cleave
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "cleave-combinators" "Cleave Combinators"
+
+{ $subsection bi  }
+{ $subsection tri }
+
+{ $notes
+  "From the Merriam-Webster Dictionary: "
+  $nl
+  { $strong "cleave" }
+  { $list
+    { $emphasis "To divide by or as if by a cutting blow" }
+    { $emphasis "To separate into distinct parts and especially into "
+                "groups having divergent views" } }
+  $nl
+  "The Joy programming language has a " { $emphasis "cleave" } " combinator." }
+
+;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: bi
+
+  { $values { "x" object }
+            { "p" quotation }
+            { "q" quotation }
+          
+            { "p(x)" "p applied to x" }
+            { "q(x)" "q applied to x" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: tri
+
+  { $values { "x" object }
+            { "p" quotation }
+            { "q" quotation }
+            { "r" quotation }
+          
+            { "p(x)" "p applied to x" }
+            { "q(x)" "q applied to x" }
+            { "r(x)" "r applied to x" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "spread-combinators" "Spread Combinators"
+
+{ $subsection bi* }
+{ $subsection tri* } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: bi*
+
+  { $values { "x" object }
+            { "y" object }
+            { "p" quotation }
+            { "q" quotation }
+          
+            { "p(x)" "p applied to x" }
+            { "q(y)" "q applied to y" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: tri*
+
+  { $values { "x" object }
+            { "y" object }
+            { "z" object }
+            { "p" quotation }
+            { "q" quotation }
+            { "r" quotation }
+          
+            { "p(x)" "p applied to x" }
+            { "q(y)" "q applied to y" }
+            { "r(z)" "r applied to z" } } ;

extra/combinators/cleave/cleave.factor

@@ -7,10 +7,8 @@ IN: combinators.cleave
 ! The cleaver family
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: bi ( obj quot quot -- val val ) >r keep r> call ; inline
+: bi  ( x p q   -- p(x) q(x)      ) >r keep r> call          ; inline
-
+: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline
-: tri ( obj quot quot quot -- val val val )
-  >r pick >r bi r> r> call ; inline
 
 : tetra ( obj quot quot quot quot -- val val val val )
   >r >r pick >r bi r> r> r> bi ; inline
@@ -39,9 +37,9 @@ MACRO: cleave ( seq -- )
 ! The spread family
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
+: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
 
-: tri* ( obj obj obj quot quot quot -- val val val )
+: tri* ( x y z p q r -- p(x) q(y) r(z) )
   >r rot >r bi* r> r> call ; inline
 
 : tetra* ( obj obj obj obj quot quot quot quot -- val val val val )

extra/concurrency/distributed/distributed-tests.factor

@@ -0,0 +1,31 @@
+IN: concurrency.distributed.tests
+USING: tools.test concurrency.distributed kernel io.files
+arrays io.sockets system combinators threads math sequences
+concurrency.messaging ;
+
+: test-node
+    {
+        { [ unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
+        { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }
+    } cond ;
+
+[ ] [ test-node dup 1array swap (start-node) ] unit-test
+
+[ ] [ yield ] unit-test
+
+[ ] [
+    [
+        receive first2 >r 3 + r> send
+        "thread-a" unregister-process
+    ] "Thread A" spawn
+    "thread-a" swap register-process
+] unit-test
+
+[ 8 ] [
+    5 self 2array
+    "thread-a" test-node <remote-process> send
+
+    receive
+] unit-test
+
+[ ] [ test-node stop-node ] unit-test

extra/concurrency/distributed/distributed.factor

@@ -2,35 +2,46 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: serialize sequences concurrency.messaging
 threads io io.server qualified arrays
-namespaces kernel io.encodings.binary ;
+namespaces kernel io.encodings.binary combinators.cleave
+new-slots accessors ;
 QUALIFIED: io.sockets
 IN: concurrency.distributed
 
 SYMBOL: local-node
 
 : handle-node-client ( -- )
-    deserialize first2 get-process send ;
+    deserialize
+    [ first2 get-process send ]
+    [ stop-server ] if* ;
 
 : (start-node) ( addrspecs addrspec -- )
-    [
     local-node set-global
+    [
         "concurrency.distributed"
-        binary [ handle-node-client ] with-server
+        binary
-    ] 2curry f spawn drop ;
+        [ handle-node-client ] with-server
+    ] curry "Distributed concurrency server" spawn drop ;
 
 : start-node ( port -- )
-    dup internet-server io.sockets:host-name
+    [ internet-server ]
-    rot io.sockets:<inet> (start-node) ;
+    [ io.sockets:host-name swap io.sockets:<inet> ] bi
+    (start-node) ;
 
 TUPLE: remote-process id node ;
 
 C: <remote-process> remote-process
 
+: send-remote-message ( message node -- )
+    binary io.sockets:<client>
+    [ serialize ] with-stream ;
+
 M: remote-process send ( message thread -- )
-    { remote-process-id remote-process-node } get-slots
+    [ id>> 2array ] [ node>> ] bi
-    binary io.sockets:<client> [ 2array serialize ] with-stream ;
+    send-remote-message ;
 
 M: thread (serialize) ( obj -- )
-    thread-id local-node get-global
+    thread-id local-node get-global <remote-process>
-    <remote-process>
     (serialize) ;
+
+: stop-node ( node -- )
+    f swap send-remote-message ;

extra/db/postgresql/postgresql-tests.factor

@@ -7,7 +7,7 @@ db.tuples db.types unicode.case ;
 IN: db.postgresql.tests
 
 : test-db ( -- postgresql-db )
-    { "localhost" "postgres" "" "factor-test" } postgresql-db ;
+    { "localhost" "postgres" "foob" "factor-test" } postgresql-db ;
 
 [ ] [ test-db [ ] with-db ] unit-test
 

extra/db/tuples/tuples-tests.factor

@@ -186,7 +186,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
     >r "tuples-test.db" temp-file sqlite-db r> with-db ;
 
 : test-postgresql ( -- )
->r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
+>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
 [ native-person-schema test-tuples ] test-sqlite
 [ assigned-person-schema test-tuples ] test-sqlite

extra/farkup/farkup-tests.factor

@@ -43,6 +43,21 @@ IN: farkup.tests
 [ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
 [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
 
-[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
 [ "<h1>foo</h1>\n" ] [ "=foo=\n" convert-farkup ] unit-test
 [ "<p>lol</p><h1>foo</h1>\n" ] [ "lol=foo=\n" convert-farkup ] unit-test
+[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
+[ "<p>=foo</p>" ] [ "=foo" convert-farkup ] unit-test
+[ "<p>==foo</p>" ] [ "==foo" convert-farkup ] unit-test
+[ "<p>=</p><h1>foo</h1>" ] [ "==foo=" convert-farkup ] unit-test
+[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
+[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
+[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
+[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
+
+[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
+[ "[c{int main()}]" convert-farkup ] unit-test
+
+[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
+[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
+[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test

extra/farkup/farkup.factor

@@ -42,14 +42,44 @@ MEMO: h2 ( -- parser ) "==" "h2" delimited ;
 MEMO: h3 ( -- parser ) "===" "h3" delimited ;
 MEMO: h4 ( -- parser ) "====" "h4" delimited ;
 
+MEMO: eq ( -- parser )
+    [
+        h1 ensure-not ,
+        h2 ensure-not ,
+        h3 ensure-not ,
+        h4 ensure-not ,
+        "=" token ,
+    ] seq* ;
+
 : render-code ( string mode -- string' )
     >r string-lines r>
     [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
 
+: escape-link ( href text -- href-esc text-esc )
+    >r escape-quoted-string r> escape-string ;
+
 : make-link ( href text -- seq )
-    >r escape-quoted-string r> escape-string
+    escape-link
     [ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
 
+: make-image-link ( href alt -- seq )
+    escape-link
+    [
+        "<img src=\"" , swap , "\"" ,
+        dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+        "/>" , ]
+    { } make ;
+
+MEMO: image-link ( -- parser )
+    [
+        "[[image:" token hide ,
+        [ "|]" member? not ] satisfy repeat1 [ >string ] action ,
+        "|" token hide
+            [ CHAR: ] = not ] satisfy repeat0 2seq
+            [ first >string ] action optional ,
+        "]]" token hide ,
+    ] seq* [ first2 make-image-link ] action ;
+
 MEMO: simple-link ( -- parser )
     [
         "[[" token hide ,
@@ -66,7 +96,7 @@ MEMO: labelled-link ( -- parser )
         "]]" token hide ,
     ] seq* [ first2 make-link ] action ;
 
-MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ;
+MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
 
 DEFER: line
 MEMO: list-item ( -- parser )
@@ -92,20 +122,17 @@ MEMO: table ( -- parser )
 MEMO: code ( -- parser )
     [
         "[" token hide ,
-        [ "{" member? not ] satisfy repeat1 optional [ >string ] action ,
+        [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
         "{" token hide ,
-        [
+        "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
-            [ any-char , "}]" token ensure-not , ] seq*
+        "}]" token hide ,
-            repeat1 [ concat >string ] action ,
-            [ any-char , "}]" token hide , ] seq* optional [ >string ] action ,
-        ] seq* [ concat ] action ,
     ] seq* [ first2 swap render-code ] action ;
 
 MEMO: line ( -- parser )
     [
         text , strong , emphasis , link ,
         superscript , subscript , inline-code ,
-        escaped-char , delimiter ,
+        escaped-char , delimiter , eq ,
     ] choice* repeat1 ;
 
 MEMO: paragraph ( -- parser )

extra/help/handbook/handbook.factor

@@ -116,6 +116,7 @@ ARTICLE: "objects" "Objects"
 { $subsection "classes" }
 { $subsection "tuples" }
 { $subsection "generic" }
+{ $subsection "slots" }
 { $subsection "mirrors" } ;
 
 USE: random
@@ -235,7 +236,7 @@ ARTICLE: "program-org" "Program organization"
 USING: help.cookbook help.tutorial ;
 
 ARTICLE: "handbook" "Factor documentation"
-"Welcome to Factor. Factor is dynamically-typed, stack-based, and very expressive. It is one of the most powerful and flexible programming languages ever invented. Have fun with Factor!"
+"Welcome to Factor."
 { $heading "Starting points" }
 { $subsection "cookbook" }
 { $subsection "first-program" }
@@ -261,6 +262,7 @@ ARTICLE: "handbook" "Factor documentation"
 { $subsection "help" }
 { $subsection "inference" }
 { $subsection "compiler" }
+{ $subsection "layouts" }
 { $heading "User interface" }
 { $about "ui" }
 { $about "ui.tools" }

extra/help/help-docs.factor

@@ -344,7 +344,7 @@ HELP: $side-effects
 
 HELP: $notes
 { $values { "element" "a markup element" } }
-{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ;
+{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ;
 
 HELP: $see
 { $values { "element" "a markup element of the form " { $snippet "{ word }" } } }

extra/locals/locals-tests.factor

@@ -116,6 +116,12 @@ write-test-2 "q" set
 
 [ ] [ 5 write-test-4 drop ] unit-test
 
+! Not really a write test; just enforcing consistency
+:: write-test-5 ( x -- y )
+    [wlet | fun! [ x + ] | 5 fun! ] ;
+
+[ 9 ] [ 4 write-test-5 ] unit-test
+
 SYMBOL: a
 
 :: use-test ( a b c -- a b c )
@@ -160,3 +166,15 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 [ ] [ \ lambda-generic-2 see ] unit-test
 
 [ ] [ \ lambda-generic see ] unit-test
+
+[ "[let | a! [ ] | ]" ] [
+    [let | a! [ ] | ] unparse
+] unit-test
+
+[ "[wlet | a! [ ] | ]" ] [
+    [wlet | a! [ ] | ] unparse
+] unit-test
+
+[ "[| a! | ]" ] [
+    [| a! | ] unparse
+] unit-test

extra/locals/locals.factor

@@ -317,7 +317,7 @@ M: lambda pprint*
     \ | pprint-word
     t <inset
     <block
-    values [ <block >r pprint-word r> pprint* block> ] 2each
+    values [ <block >r pprint-var r> pprint* block> ] 2each
     block>
     \ | pprint-word
     <block pprint-elements block>
@@ -329,7 +329,7 @@ M: let pprint*
     \ ] pprint-word ;
 
 M: wlet pprint*
-    \ [let pprint-word
+    \ [wlet pprint-word
     { wlet-body wlet-vars wlet-bindings } get-slots pprint-let
     \ ] pprint-word ;
 

extra/math/constants/constants-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel layouts ;
+USING: help.markup help.syntax kernel ;
 IN: math.constants
 
 ARTICLE: "math-constants" "Constants"
@@ -7,9 +7,6 @@ ARTICLE: "math-constants" "Constants"
 { $subsection euler }
 { $subsection phi }
 { $subsection pi }
-"Various limits:"
-{ $subsection most-positive-fixnum }
-{ $subsection most-negative-fixnum }
 { $subsection epsilon } ;
 
 ABOUT: "math-constants"

extra/peg/parsers/parsers-docs.factor

@@ -1,9 +1,19 @@
-! Copyright (C) 2007 Chris Double.
+! Copyright (C) 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax peg peg.parsers.private
 unicode.categories ;
 IN: peg.parsers
 
+HELP: 1token
+{ $values
+    { "ch" "a character" }
+    { "parser" "a parser" }
+} { $description
+    "Calls 1string on a character and returns a parser that matches that character."
+} { $examples
+    { $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" }
+} { $see-also 'string' } ;
+
 HELP: (list-of)
 { $values
     { "items" "a sequence" }

extra/peg/parsers/parsers.factor

@@ -21,6 +21,8 @@ M: just-parser compile ( parser -- quot )
 MEMO: just ( parser -- parser )
   just-parser construct-boa init-parser ;
 
+MEMO: 1token ( ch -- parser ) 1string token ;
+
 <PRIVATE
 MEMO: (list-of) ( items separator repeat1? -- parser )
   >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq

extra/semantic-db/type/type.factor

@@ -1,48 +0,0 @@
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays db db.types kernel semantic-db sequences sequences.lib ;
-IN: semantic-db.type
-
-! types:
-!  - have type 'type' in context 'semantic-db'
-!  - have a context in context 'semantic-db'
-
-: assign-type ( type nid -- arc-id )
-    has-type-relation spin arc-id ;
-
-: create-node-of-type ( type content -- node-id )
-    node-id [ assign-type drop ] keep ;
-
-: select-nodes-of-type ( type -- node-ids )
-    ":type" INTEGER param
-    has-type-relation ":has_type" INTEGER param 2array
-    "select a.subject from arc a where a.relation = :has_type and a.object = :type"
-    single-int-results ;
-
-: select-node-of-type ( type -- node-id )
-    select-nodes-of-type ?first ;
-
-: select-nodes-of-type-with-content ( type content -- node-ids )
-    ! find nodes with the given content that are the subjects of arcs with:
-    !     relation = has-type-relation
-    !     object = type
-    ":name" TEXT param
-    swap ":type" INTEGER param
-    has-type-relation ":has_type" INTEGER param 3array
-    "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type"
-    single-int-results ;
-
-: select-node-of-type-with-content ( type content -- node-id/f )
-    select-nodes-of-type-with-content ?first ;
-
-: ensure-node-of-type ( type content -- node-id )
-    [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ;
-    ! 2dup select-node-of-type-with-content [ 2nip ] [ create-node-of-type ] if* ;
-
-
-: ensure-type ( type -- node-id )
-    dup "type" = [
-        drop type-type
-    ] [
-        type-type swap ensure-node-of-type
-    ] if ;

extra/serialize/serialize.factor

@@ -11,7 +11,8 @@ USING: namespaces sequences kernel math io math.functions
 io.binary strings classes words sbufs tuples arrays
 vectors byte-arrays bit-arrays quotations hashtables
 assocs help.syntax help.markup float-arrays splitting
-io.encodings.string io.encodings.utf8 combinators ;
+io.encodings.string io.encodings.utf8 combinators new-slots
+accessors ;
 
 ! Variable holding a assoc of objects already serialized
 SYMBOL: serialized
@@ -20,9 +21,9 @@ TUPLE: id obj ;
 
 C: <id> id
 
-M: id hashcode* id-obj hashcode* ;
+M: id hashcode* obj>> hashcode* ;
 
-M: id equal? over id? [ [ id-obj ] 2apply eq? ] [ 2drop f ] if ;
+M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ;
 
 : add-object ( obj -- )
     #! Add an object to the sequence of already serialized
@@ -103,7 +104,7 @@ M: ratio (serialize) ( obj -- )
 M: string (serialize) ( obj -- )
     [ CHAR: s serialize-string ] serialize-shared ;
 
-: serialize-elements
+: serialize-elements ( seq -- )
     [ (serialize) ] each CHAR: . write1 ;
 
 M: tuple (serialize) ( obj -- )

extra/tools/walker/walker.factor

@@ -32,14 +32,17 @@ SYMBOL: walking-thread
 
 \ break t "break?" set-word-prop
 
+: walk ( quot -- quot' )
+    \ break add* [ break rethrow ] recover ;
+
 : add-breakpoint ( quot -- quot' )
     dup [ break ] head? [ \ break add* ] unless ;
 
-: walk ( quot -- ) add-breakpoint call ;
+: (step-into-quot) ( quot -- ) add-breakpoint call ;
 
-: (step-into-if) ? walk ;
+: (step-into-if) ? (step-into-quot) ;
 
-: (step-into-dispatch) nth walk ;
+: (step-into-dispatch) nth (step-into-quot) ;
 
 : (step-into-execute) ( word -- )
     dup "step-into" word-prop [
@@ -48,7 +51,7 @@ SYMBOL: walking-thread
         dup primitive? [
             execute break
         ] [
-            word-def walk
+            word-def (step-into-quot)
         ] if
     ] ?if ;
 
@@ -104,8 +107,8 @@ SYMBOL: +detached+
     [ nip \ break add ] change-frame ;
 
 {
-    { call [ walk ] }
+    { call [ (step-into-quot) ] }
-    { (throw) [ drop walk ] }
+    { (throw) [ drop (step-into-quot) ] }
     { execute [ (step-into-execute) ] }
     { if [ (step-into-if) ] }
     { dispatch [ (step-into-dispatch) ] }

extra/ui/cocoa/views/views.factor

@@ -297,7 +297,7 @@ CLASS: {
 { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
     [
         [
-            2drop dup view-dim swap window set-gadget-dim
+            2drop dup view-dim swap window set-gadget-dim yield
         ] ui-try
     ]
 }

extra/ui/gestures/gestures.factor

@@ -119,7 +119,8 @@ SYMBOL: drag-timer
 
 : stop-drag-timer ( -- )
     hand-buttons get-global empty? [
-        drag-timer get-global box> cancel-alarm
+        drag-timer get-global ?box
+        [ cancel-alarm ] [ drop ] if
     ] when ;
 
 : fire-motion ( -- )

extra/ui/ui.factor

@@ -148,7 +148,7 @@ SYMBOL: ui-thread
     \ ui-running get-global ;
 
 : update-ui-loop ( -- )
-    ui-running? ui-thread get-global self eq? [
+    ui-running? ui-thread get-global self eq? and [
         ui-notify-flag get lower-flag
         [ update-ui ] ui-try
         update-ui-loop

extra/unix/stat/freebsd/freebsd.factor

@@ -0,0 +1,30 @@
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! FreeBSD 8.0-CURRENT
+
+C-STRUCT: stat
+    { "__dev_t"    "st_dev" }
+    { "ino_t"      "st_ino" }
+    { "mode_t"     "st_mode" }
+    { "nlink_t"    "st_nlink" }
+    { "uid_t"      "st_uid" }
+    { "gid_t"      "st_gid" }
+    { "__dev_t"    "st_rdev" }
+    { "timespec"   "st_atim" }
+    { "timespec"   "st_mtim" }
+    { "timespec"   "st_ctim" }
+    { "off_t"      "st_size" }
+    { "blkcnt_t"   "st_blocks" }
+    { "blksize_t"  "st_blksize" }
+    { "fflags_t"   "st_flags" }
+    { "__uint32_t" "st_gen" }
+    { "__int32_t"  "st_lspare" }
+    { "timespec"   "st_birthtimespec" }
+! not sure about the padding here.
+    { "__uint32_t" "pad0" }
+    { "__uint32_t" "pad1" } ;
+
+FUNCTION: int stat  ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;

extra/unix/stat/linux/linux.factor

@@ -1,5 +1,5 @@
 
-USING: system combinators vocabs.loader ;
+USING: layouts combinators vocabs.loader ;
 
 IN: unix.stat
 

extra/unix/stat/stat.factor

@@ -62,6 +62,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
   {
     { "linux"   [ "unix.stat.linux"   require ] }
     { "macosx"  [ "unix.stat.macosx"  require ] }
+    { "freebsd" [ "unix.stat.freebsd" require ] }
     [ drop ]
   }
   case

extra/unix/types/freebsd/freebsd.factor

@@ -0,0 +1,19 @@
+USING: alien.syntax ;
+
+IN: unix.types
+
+TYPEDEF: ushort          __uint16_t
+TYPEDEF: uint           __uint32_t
+TYPEDEF: int            __int32_t
+TYPEDEF: longlong       __int64_t
+
+TYPEDEF: __uint32_t     __dev_t
+TYPEDEF: __uint32_t     ino_t
+TYPEDEF: __uint16_t     mode_t
+TYPEDEF: __uint16_t     nlink_t
+TYPEDEF: __uint32_t     uid_t
+TYPEDEF: __uint32_t     gid_t
+TYPEDEF: __int64_t      off_t
+TYPEDEF: __int64_t      blkcnt_t
+TYPEDEF: __uint32_t     blksize_t
+TYPEDEF: __uint32_t     fflags_t

extra/unix/types/types.factor

@@ -9,6 +9,7 @@ os
   {
     { "linux"   [ "unix.types.linux"   require ] }
     { "macosx"  [ "unix.types.macosx"  require ] }
+    { "freebsd" [ "unix.types.freebsd" require ] }
     [ drop ]
   }
 case