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

basis/alien/structs/fields/fields.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel kernel.private math namespaces
+sequences strings words effects combinators alien.c-types ;
+IN: alien.structs.fields
+
+TUPLE: field-spec name offset type reader writer ;
+
+: reader-effect ( type spec -- effect )
+    [ 1array ] [ name>> 1array ] bi* <effect> ;
+
+PREDICATE: slot-reader < word "reading" word-prop >boolean ;
+
+: set-reader-props ( class spec -- )
+    2dup reader-effect
+    over reader>>
+    swap "declared-effect" set-word-prop
+    reader>> swap "reading" set-word-prop ;
+
+: writer-effect ( type spec -- effect )
+    name>> swap 2array 0 <effect> ;
+
+PREDICATE: slot-writer < word "writing" word-prop >boolean ;
+
+: set-writer-props ( class spec -- )
+    2dup writer-effect
+    over writer>>
+    swap "declared-effect" set-word-prop
+    writer>> swap "writing" set-word-prop ;
+
+: reader-word ( class name vocab -- word )
+    >r >r "-" r> 3append r> create ;
+
+: writer-word ( class name vocab -- word )
+    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+
+: <field-spec> ( struct-name vocab type field-name -- spec )
+    field-spec new
+        0 >>offset
+        swap >>name
+        swap expand-constants >>type
+        3dup name>> swap reader-word >>reader
+        3dup name>> swap writer-word >>writer
+    2nip ;
+
+: align-offset ( offset type -- offset )
+    c-type-align align ;
+
+: struct-offsets ( specs -- size )
+    0 [
+        [ type>> align-offset ] keep
+        [ (>>offset) ] [ type>> heap-size + ] 2bi
+    ] reduce ;
+
+: define-struct-slot-word ( spec word quot -- )
+    rot offset>> prefix define-inline ;
+
+: define-getter ( type spec -- )
+    [ set-reader-props ] keep
+    [ ]
+    [ reader>> ]
+    [
+        type>>
+        [ c-getter ] [ c-type-boxer-quot ] bi append
+    ] tri
+    define-struct-slot-word ;
+
+: define-setter ( type spec -- )
+    [ set-writer-props ] keep
+    [ ]
+    [ writer>> ]
+    [ type>> c-setter ] tri
+    define-struct-slot-word ;
+
+: define-field ( type spec -- )
+    [ define-getter ] [ define-setter ] 2bi ;

basis/alien/structs/structs-docs.factor

@@ -1,75 +1,7 @@
-IN: alien.structs
 USING: accessors alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays slots.deprecated
+alien.syntax sequences io arrays kernel words assocs namespaces
-kernel words slots assocs namespaces accessors ;
+accessors ;
-
+IN: alien.structs
-! Deprecated code
-: ($spec-reader-values) ( slot-spec class -- element )
-    dup ?word-name swap 2array
-    over name>>
-    rot class>> 2array 2array
-    [ { $instance } swap suffix ] assoc-map ;
-
-: $spec-reader-values ( slot-spec class -- )
-    ($spec-reader-values) $values ;
-
-: $spec-reader-description ( slot-spec class -- )
-    [
-        "Outputs the value stored in the " ,
-        { $snippet } rot name>> suffix ,
-        " slot of " ,
-        { $instance } swap suffix ,
-        " instance." ,
-    ] { } make $description ;
-
-: slot-of-reader ( reader specs -- spec/f )
-    [ reader>> eq? ] with find nip ;
-
-: $spec-reader ( reader slot-specs class -- )
-    >r slot-of-reader r>
-    over [
-        2dup $spec-reader-values
-        2dup $spec-reader-description
-    ] when 2drop ;
-
-GENERIC: slot-specs ( help-type -- specs )
-
-M: word slot-specs "slots" word-prop ;
-
-: $slot-reader ( reader -- )
-    first dup "reading" word-prop [ slot-specs ] keep
-    $spec-reader ;
-
-: $spec-writer-values ( slot-spec class -- )
-    ($spec-reader-values) reverse $values ;
-
-: $spec-writer-description ( slot-spec class -- )
-    [
-        "Stores a new value to the " ,
-        { $snippet } rot name>> suffix ,
-        " slot of " ,
-        { $instance } swap suffix ,
-        " instance." ,
-    ] { } make $description ;
-
-: slot-of-writer ( writer specs -- spec/f )
-    [ writer>> eq? ] with find nip ;
-
-: $spec-writer ( writer slot-specs class -- )
-    >r slot-of-writer r>
-    over [
-        2dup $spec-writer-values
-        2dup $spec-writer-description
-        dup ?word-name 1array $side-effects
-    ] when 2drop ;
-
-: $slot-writer ( reader -- )
-    first dup "writing" word-prop [ slot-specs ] keep
-    $spec-writer ;
-
-M: string slot-specs c-type fields>> ;
-
-M: array ($instance) first ($instance) " array" write ;
 
 ARTICLE: "c-structs" "C structure types"
 "A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."

basis/alien/structs/structs.factor

@@ -1,43 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc slots
+math namespaces parser sequences strings words libc
-slots.deprecated alien.c-types cpu.architecture ;
+alien.c-types alien.structs.fields cpu.architecture ;
 IN: alien.structs
 
-: align-offset ( offset type -- offset )
-    c-type-align align ;
-
-: struct-offsets ( specs -- size )
-    0 [
-        [ class>> align-offset ] keep
-        [ (>>offset) ] 2keep
-        class>> heap-size +
-    ] reduce ;
-
-: define-struct-slot-word ( spec word quot -- )
-    rot offset>> prefix define-inline ;
-
-: define-getter ( type spec -- )
-    [ set-reader-props ] keep
-    [ ]
-    [ reader>> ]
-    [
-        class>>
-        [ c-getter ] [ c-type-boxer-quot ] bi append
-    ] tri
-    define-struct-slot-word ;
-
-: define-setter ( type spec -- )
-    [ set-writer-props ] keep
-    [ ]
-    [ writer>> ]
-    [ class>> c-setter ] tri
-    define-struct-slot-word ;
-
-: define-field ( type spec -- )
-    2dup define-getter define-setter ;
-
 : if-value-structs? ( ctype true false -- )
     value-structs?
     [ drop call ] [ >r 2drop "void*" r> call ] if ; inline
@@ -76,17 +43,8 @@ M: struct-type stack-size
     struct-type boa
     -rot define-c-type ;
 
-: make-field ( struct-name vocab type field-name -- spec )
-    <slot-spec>
-        0 >>offset
-        swap >>name
-        swap expand-constants >>class
-        3dup name>> swap reader-word >>reader
-        3dup name>> swap writer-word >>writer
-    2nip ;
-
 : define-struct-early ( name vocab fields -- fields )
-    -rot [ rot first2 make-field ] 2curry map ;
+    -rot [ rot first2 <field-spec> ] 2curry map ;
 
 : compute-struct-align ( types -- n )
     [ c-type-align ] map supremum ;
@@ -94,7 +52,7 @@ M: struct-type stack-size
 : define-struct ( name vocab fields -- )
     pick >r
     [ struct-offsets ] keep
-    [ [ class>> ] map compute-struct-align ] keep
+    [ [ type>> ] map compute-struct-align ] keep
     [ (define-struct) ] keep
     r> [ swap define-field ] curry each ;
 

basis/bootstrap/image/image.factor

@@ -358,7 +358,7 @@ M: byte-array '
 
 ! Tuples
 : (emit-tuple) ( tuple -- pointer )
-    [ tuple>array rest-slice ]
+    [ tuple-slots ]
     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
@@ -384,9 +384,9 @@ M: tuple-layout '
     ] cache-object ;
 
 M: tombstone '
-    delegate
+    state>> "((tombstone))" "((empty))" ?
-    "((tombstone))" "((empty))" ? "hashtables.private" lookup
+    "hashtables.private" lookup def>> first
-    def>> first [ emit-tuple ] cache-object ;
+    [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '

basis/calendar/backend/backend.factor

@@ -1,4 +0,0 @@
-USING: kernel system ;
-IN: calendar.backend
-
-HOOK: gmt-offset os ( -- hours minutes seconds )

basis/calendar/calendar-docs.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math strings help.markup help.syntax
-calendar.backend ;
+math.order ;
 IN: calendar
 
 HELP: duration
-{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds.  All duration slots can store " { $link real } " numbers." } ;
+{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds.  All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
 
 HELP: timestamp
-{ $description "A timestamp is a date and a time with a timezone offset.  Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } "." } ;
+{ $description "A timestamp is a date and a time with a timezone offset.  Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ;
 
 { timestamp duration } related-words
 
@@ -128,3 +128,479 @@ HELP: >time<
 } ;
 
 { >date< >time< } related-words
+
+HELP: instant
+{ $values { "duration" duration } }
+{ $description "Pushes a " { $snippet "duration" } " of zero seconds." } ;
+
+HELP: years
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of years." } ;
+
+HELP: months
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of months." } ;
+
+HELP: days
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of days." } ;
+
+HELP: weeks
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of weeks." } ;
+
+HELP: hours
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of hours." } ;
+
+HELP: minutes
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of minutes." } ;
+
+HELP: seconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of seconds." } ;
+
+HELP: milliseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of milliseconds." } ;
+
+{ years months days hours minutes seconds milliseconds } related-words
+
+HELP: leap-year?
+{ $values { "obj" object } { "?" "a boolean" } }
+{ $description "Returns " { $link t } " if the object represents a leap year." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "2008 leap-year? ."
+               "t"
+    }
+    { $example "USING: calendar prettyprint ;"
+               "2010 1 1 <date> leap-year? ."
+               "f"
+    }
+} ;
+
+HELP: time+
+{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
+{ $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." }
+{ $examples
+    { $example "USING: calendar math.order prettyprint ;"
+               "10 months 2 months time+ 1 years <=> ."
+               "+eq+"
+    }
+    { $example "USING: accessors calendar math.order prettyprint ;"
+               "2010 1 1 <date> 3 days time+ day>> ."
+               "4"
+    }
+} ;
+
+HELP: duration>years
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in years." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 months duration>years ."
+               "1/2"
+    }
+} ;
+
+HELP: duration>months
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in months." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "30 days duration>months ."
+               "16000/16233"
+    }
+} ;
+
+HELP: duration>days
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in days." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 hours duration>days ."
+               "1/4"
+    }
+} ;
+
+HELP: duration>hours
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in hours." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "3/4 days duration>hours ."
+               "18"
+    }
+} ;
+HELP: duration>minutes
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in minutes." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 hours duration>minutes ."
+               "360"
+    }
+} ;
+HELP: duration>seconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in seconds." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 minutes duration>seconds ."
+               "360"
+    }
+} ;
+
+HELP: duration>milliseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in milliseconds." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 seconds duration>milliseconds ."
+               "6000"
+    }
+} ;
+
+{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words
+
+
+HELP: time-
+{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
+{ $description "Subtracts two durations to produce a duration or subtracts a duration from a timestamp to produce a timestamp. The calculation takes timezones into account." }
+{ $examples
+    { $example "USING: calendar math.order prettyprint ;"
+               "10 months 2 months time- 8 months <=> ."
+               "+eq+"
+    }
+    { $example "USING: accessors calendar math.order prettyprint ;"
+               "2010 1 1 <date> 3 days time- day>> ."
+               "29"
+    }
+} ;
+
+HELP: convert-timezone
+{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
+{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
+{ $examples
+    { $example "USING: accessors calendar prettyprint ;"
+               "gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ."
+               "-5"
+    }
+} ;
+
+HELP: >local-time
+{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
+{ $examples
+    { $example "USING: accessors calendar kernel prettyprint ;"
+               "now gmt >local-time [ gmt-offset>> ] bi@ = ."
+               "t"
+    }
+} ;
+
+HELP: >gmt
+{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
+{ $examples
+    { $example "USING: accessors calendar kernel prettyprint ;"
+               "now >gmt gmt-offset>> hour>> ."
+               "0"
+    }
+} ;
+
+HELP: time*
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } }
+{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result.  Used in the implementation of " { $link before } "." } ;
+{ time+ time- time* } related-words
+
+HELP: before
+{ $values { "duration" duration } { "-duration" duration } }
+{ $description "Negates a duration." }
+{ $examples
+    { $example "USING: accessors calendar prettyprint ;"
+               "3 hours before now noon time+ hour>> ."
+               "9"
+    }
+} ;
+
+HELP: <zero>
+{ $values { "timestamp" timestamp } }
+{ $description "Outputs a zero timestamp that consists of zeros for every slot.  Used to see if timestamps are valid." } ;
+
+HELP: valid-timestamp?
+{ $values { "timestamp" timestamp } { "?" "a boolean" } }
+{ $description "Tests if a timestamp is valid or not." } ;
+
+HELP: unix-1970
+{ $values { "timestamp" timestamp } }
+{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
+
+HELP: millis>timestamp
+{ $values { "x" number } { "timestamp" timestamp } }
+{ $description "Converts a number of milliseconds into a timestamp value in GMT time." }
+{ $examples
+    { $example "USING: accessors calendar prettyprint ;"
+               "1000 millis>timestamp year>> ."
+               "1970"
+    }
+} ;
+
+HELP: gmt
+{ $values { "timestamp" timestamp } }
+{ $description "Outputs the time right now, but in the GMT timezone." } ;
+
+{ gmt now } related-words
+
+HELP: now
+{ $values { "timestamp" timestamp } }
+{ $description "Outputs the time right now in your computer's timezone." }
+{ $examples
+    { $unchecked-example "USING: calendar prettyprint ;"
+        "now ."
+         "T{ timestamp f 2008 9 1 16 38 24+801/1000 T{ duration f 0 0 0 -5 0 0 } }"
+    }
+} ;
+
+HELP: hence
+{ $values { "duration" duration } { "timestamp" timestamp } }
+{ $description "Computes a time in the future that is the " { $snippet "duration" } " added to the result of " { $link now } "." }
+{ $examples
+    { $unchecked-example
+       "USING: calendar prettyprint ;"
+       "10 hours hence ."
+       "T{ timestamp f 2008 9 2 2 47 45+943/1000 T{ duration f 0 0 0 -5 0 0 } }"
+    }
+} ;
+
+HELP: ago
+{ $values { "duration" duration } { "timestamp" timestamp } }
+{ $description "Computes a time in the past that is the " { $snippet "duration" } " subtracted from the result of " { $link now } "." }
+{ $examples
+    { $unchecked-example
+       "USING: calendar prettyprint ;"
+       "3 weeks ago ."
+       "T{ timestamp f 2008 8 11 16 49 52+99/500 T{ duration f 0 0 0 -5 0 0 } }"
+    }
+} ;
+
+HELP: zeller-congruence
+{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
+{ $description "An implementation of an algorithm that computes the day of the week given a date. Days are indexed starting from Sunday, which is index 0." }
+{ $notes "User code should use the " { $link day-of-week } " word, which takes a " { $snippet "timestamp" } " instead of integers." } ;
+
+HELP: days-in-year
+{ $values { "obj" "a timestamp or an integer" } { "n" integer } } 
+{ $description "Calculates the number of days in a given year." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "2004 days-in-year ."
+               "366"
+    }
+} ;
+
+HELP: days-in-month
+{ $values { "timestamp" timestamp } { "n" integer } }
+{ $description "Calculates the number of days in a given month." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "2008 8 24 <date> days-in-month ."
+               "31"
+    }
+} ;
+
+HELP: day-of-week
+{ $values { "timestamp" timestamp } { "n" integer } }
+{ $description "Calculates the index of the day of the week. Sunday will result in an index of 0." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "now sunday day-of-week ."
+               "0"
+    }
+} ;
+
+HELP: day-of-year
+{ $values { "timestamp" timestamp } { "n" integer } }
+{ $description "Calculates the day of the year, resulting in a number from 1 to 366 (leap years)." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "2008 1 4 <date> day-of-year ."
+               "4"
+    }
+} ;
+
+HELP: sunday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Sunday from the current week, which starts on a Sunday." } ;
+
+HELP: monday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Monday from the current week, which starts on a Sunday." } ;
+
+HELP: tuesday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Tuesday from the current week, which starts on a Sunday." } ;
+
+HELP: wednesday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Wednesday from the current week, which starts on a Sunday." } ;
+
+HELP: thursday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Thursday from the current week, which starts on a Sunday." } ;
+
+HELP: friday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Friday from the current week, which starts on a Sunday." } ;
+
+HELP: saturday
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns the Saturday from the current week, which starts on a Sunday." } ;
+
+{ sunday monday tuesday wednesday thursday friday saturday } related-words
+
+HELP: midnight
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns a timestamp that represents today at midnight, or the beginning of the day." } ;
+
+HELP: noon
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Returns a timestamp that represents today at noon, or the middle of the day." } ;
+
+HELP: beginning-of-month
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Outputs a timestamp with the day set to one." } ;
+
+HELP: beginning-of-week
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Outputs a timestamp where the day of the week is Sunday." } ;
+
+HELP: beginning-of-year
+{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $description "Outputs a timestamp with the month and day set to one, or January 1 of the input timestamp." } ;
+
+HELP: time-since-midnight
+{ $values { "timestamp" timestamp } { "duration" duration } }
+{ $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
+
+ARTICLE: "calendar" "Calendar"
+"The two data types used throughout the calendar library:"
+{ $subsection timestamp }
+{ $subsection duration }
+"Durations represent spans of time:"
+{ $subsection "using-durations" }
+"Arithmetic on timestamps and durations:"
+{ $subsection "timestamp-arithmetic" }
+"Getting the current timestamp:"
+{ $subsection now }
+{ $subsection gmt }
+"Converting between timestamps:"
+{ $subsection >local-time }
+{ $subsection >gmt }
+"Converting between timezones:"
+{ $subsection convert-timezone }
+"Timestamps relative to each other:"
+{ $subsection "relative-timestamps" }
+"Operations on units of time:"
+{ $subsection "years" }
+{ $subsection "months" }
+{ $subsection "days" }
+"Meta-data about the calendar:"
+{ $subsection "calendar-facts" }
+;
+
+ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic"
+"Adding timestamps and durations, or durations and durations:"
+{ $subsection time+ }
+"Subtracting:"
+{ $subsection time- }
+"Element-wise multiplication:"
+{ $subsection time* } ;
+
+ARTICLE: "using-durations" "Using durations"
+"Creating a duration object:"
+{ $subsection years }
+{ $subsection months }
+{ $subsection weeks }
+{ $subsection days }
+{ $subsection hours }
+{ $subsection minutes }
+{ $subsection seconds }
+{ $subsection milliseconds }
+{ $subsection instant }
+"Converting a duration to a number:"
+{ $subsection duration>years }
+{ $subsection duration>months }
+{ $subsection duration>days }
+{ $subsection duration>hours }
+{ $subsection duration>minutes }
+{ $subsection duration>seconds }
+{ $subsection duration>milliseconds } ;
+
+ARTICLE: "relative-timestamps" "Relative timestamps"
+"In the future:"
+{ $subsection hence }
+"In the past:"
+{ $subsection ago }
+"Invert a duration:"
+{ $subsection before }
+"Days of the week relative to " { $link now } ":"
+{ $subsection sunday }
+{ $subsection monday }
+{ $subsection tuesday }
+{ $subsection wednesday }
+{ $subsection thursday }
+{ $subsection friday }
+{ $subsection saturday }
+"New timestamps relative to calendar events:"
+{ $subsection beginning-of-year }
+{ $subsection beginning-of-month }
+{ $subsection beginning-of-week }
+{ $subsection midnight }
+{ $subsection noon }
+;
+
+ARTICLE: "days" "Day operations"
+"Naming days:"
+{ $subsection day-abbreviation2 }
+{ $subsection day-abbreviations2 }
+{ $subsection day-abbreviation3 }
+{ $subsection day-abbreviations3 }
+{ $subsection day-name }
+{ $subsection day-names }
+"Calculating a Julian day number:"
+{ $subsection julian-day-number }
+"Calculate a timestamp:"
+{ $subsection julian-day-number>date }
+;
+
+ARTICLE: "calendar-facts" "Calendar facts"
+"Calendar facts:"
+{ $subsection average-month }
+{ $subsection months-per-year }
+{ $subsection days-per-year }
+{ $subsection hours-per-year }
+{ $subsection minutes-per-year }
+{ $subsection seconds-per-year }
+{ $subsection days-in-month }
+{ $subsection day-of-year }
+{ $subsection day-of-week }
+;
+
+ARTICLE: "years" "Year operations"
+"Leap year predicate:"
+{ $subsection leap-year? }
+"Find the number of days in a year:"
+{ $subsection days-in-year }
+;
+
+ARTICLE: "months" "Month operations"
+"Naming months:"
+{ $subsection month-name }
+{ $subsection month-names }
+{ $subsection month-abbreviation }
+{ $subsection month-abbreviations }
+;
+
+ABOUT: "calendar"

basis/calendar/calendar-tests.factor

@@ -33,8 +33,8 @@ IN: calendar.tests
 
 [ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
         2006 10 10 0 10 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
+[ +eq+ ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
-        2006 10 10 0 10 30 instant <timestamp> = ] unit-test
+        2006 10 10 0 10 30 instant <timestamp> <=> ] unit-test
 [ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
         2006 10 10 0 0 45 instant <timestamp> = ] unit-test
 [ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+

basis/calendar/calendar.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.functions namespaces sequences
-strings system vocabs.loader calendar.backend threads
+strings system vocabs.loader threads accessors combinators
-accessors combinators locals classes.tuple math.order
+locals classes.tuple math.order summary
-memoize summary combinators.short-circuit ;
+combinators.short-circuit ;
 IN: calendar
 
+HOOK: gmt-offset os ( -- hours minutes seconds )
+
 TUPLE: duration
     { year real }
     { month real }
@@ -60,6 +62,8 @@ PRIVATE>
 : month-abbreviation ( n -- string )
     check-month 1- month-abbreviations nth ;
 
+: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
+
 : day-names ( -- array )
     {
         "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
@@ -116,15 +120,15 @@ PRIVATE>
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
-MEMO: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
+: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
-: years ( n -- dt ) instant clone swap >>year ;
+: years ( x -- duration ) instant clone swap >>year ;
-: months ( n -- dt ) instant clone swap >>month ;
+: months ( x -- duration ) instant clone swap >>month ;
-: days ( n -- dt ) instant clone swap >>day ;
+: days ( x -- duration ) instant clone swap >>day ;
-: weeks ( n -- dt ) 7 * days ;
+: weeks ( x -- duration ) 7 * days ;
-: hours ( n -- dt ) instant clone swap >>hour ;
+: hours ( x -- duration ) instant clone swap >>hour ;
-: minutes ( n -- dt ) instant clone swap >>minute ;
+: minutes ( x -- duration ) instant clone swap >>minute ;
-: seconds ( n -- dt ) instant clone swap >>second ;
+: seconds ( x -- duration ) instant clone swap >>second ;
-: milliseconds ( n -- dt ) 1000 / seconds ;
+: milliseconds ( x -- duration ) 1000 / seconds ;
 
 GENERIC: leap-year? ( obj -- ? )
 
@@ -218,7 +222,7 @@ M: number +second ( timestamp n -- timestamp )
 
 PRIVATE>
 
-GENERIC# time+ 1 ( time dt -- time )
+GENERIC# time+ 1 ( time1 time2 -- time3 )
 
 M: timestamp time+
     >r clone r> (time+) drop ;
@@ -236,8 +240,8 @@ M: duration time+
         2drop <duration>
     ] if ;
 
-: dt>years ( dt -- x )
+: duration>years ( duration -- x )
-    #! Uses average month/year length since dt loses calendar
+    #! Uses average month/year length since duration loses calendar
     #! data
     0 swap
     {
@@ -249,16 +253,16 @@ M: duration time+
         [ second>> seconds-per-year / + ]
     } cleave ;
 
-M: duration <=> [ dt>years ] compare ;
+M: duration <=> [ duration>years ] compare ;
 
-: dt>months ( dt -- x ) dt>years months-per-year * ;
+: duration>months ( duration -- x ) duration>years months-per-year * ;
-: dt>days ( dt -- x ) dt>years days-per-year * ;
+: duration>days ( duration -- x ) duration>years days-per-year * ;
-: dt>hours ( dt -- x ) dt>years hours-per-year * ;
+: duration>hours ( duration -- x ) duration>years hours-per-year * ;
-: dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
+: duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
-: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
+: duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
-: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
+: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ;
 
-GENERIC: time- ( time1 time2 -- time )
+GENERIC: time- ( time1 time2 -- time3 )
 
 : convert-timezone ( timestamp duration -- timestamp )
     over gmt-offset>> over = [ drop ] [
@@ -296,23 +300,23 @@ M: timestamp time-
         } 2cleave <duration>
     ] if ;
 
-: before ( dt -- -dt )
+: before ( duration -- -duration )
     -1 time* ;
 
 M: duration time-
     before time+ ;
 
-MEMO: <zero> ( -- timestamp )
+: <zero> ( -- timestamp )
-0 0 0 0 0 0 instant <timestamp> ;
+    0 0 0 0 0 0 instant <timestamp> ;
 
 : valid-timestamp? ( timestamp -- ? )
     clone instant >>gmt-offset
     dup <zero> time- <zero> time+ = ;
 
-MEMO: unix-1970 ( -- timestamp )
+: unix-1970 ( -- timestamp )
     1970 1 1 0 0 0 instant <timestamp> ;
 
-: millis>timestamp ( n -- timestamp )
+: millis>timestamp ( x -- timestamp )
     >r unix-1970 r> milliseconds time+ ;
 
 : timestamp>millis ( timestamp -- n )
@@ -323,11 +327,8 @@ MEMO: unix-1970 ( -- timestamp )
     unix-1970 millis milliseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
-
+: hence ( duration -- timestamp ) now swap time+ ;
-: hence ( dt -- timestamp ) now swap time+ ;
+: ago ( duration -- timestamp ) now swap time- ;
-: ago ( dt -- timestamp ) now swap time- ;
-
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
 
 : zeller-congruence ( year month day -- n )
     #! Zeller Congruence
@@ -363,19 +364,21 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : day-of-year ( timestamp -- n )
     >date< (day-of-year) ;
 
+<PRIVATE
 : day-offset ( timestamp m -- timestamp n )
     over day-of-week - ; inline
 
 : day-this-week ( timestamp n -- timestamp )
     day-offset days time+ ;
+PRIVATE>
 
-: sunday ( timestamp -- timestamp ) 0 day-this-week ;
+: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
-: monday ( timestamp -- timestamp ) 1 day-this-week ;
+: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
-: tuesday ( timestamp -- timestamp ) 2 day-this-week ;
+: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
-: wednesday ( timestamp -- timestamp ) 3 day-this-week ;
+: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
-: thursday ( timestamp -- timestamp ) 4 day-this-week ;
+: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
-: friday ( timestamp -- timestamp ) 5 day-this-week ;
+: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
-: saturday ( timestamp -- timestamp ) 6 day-this-week ;
+: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
 
 : midnight ( timestamp -- new-timestamp )
     clone 0 >>hour 0 >>minute 0 >>second ; inline
@@ -395,7 +398,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : time-since-midnight ( timestamp -- duration )
     dup midnight time- ;
 
-
 M: timestamp sleep-until timestamp>millis sleep-until ;
 
 M: duration sleep hence sleep-until ;

basis/calendar/format/format-tests.factor

@@ -3,23 +3,23 @@ io.streams.string accessors io math.order ;
 IN: calendar.format.tests
 
 [ 0 ] [
-    "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
+    "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
 ] unit-test
 
 [ 1 ] [
-    "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
+    "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
 ] unit-test
 
 [ -1 ] [
-    "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
+    "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
 ] unit-test
 
 [ -1-1/2 ] [
-    "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
+    "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
 ] unit-test
 
 [ 1+1/2 ] [
-    "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
+    "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
 ] unit-test
 
 [ ] [ now timestamp>rfc3339 drop ] unit-test
@@ -58,7 +58,7 @@ IN: calendar.format.tests
         26
         0
         37
-        42.12345
+        42+2469/20000
         T{ duration f 0 0 0 -5 0 0 }
     }
 ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test

basis/calendar/unix/unix.factor

@@ -1,5 +1,5 @@
-USING: alien alien.c-types arrays calendar.backend
+USING: alien alien.c-types arrays calendar kernel structs
-kernel structs math unix.time namespaces system ;
+math unix.time namespaces system ;
 IN: calendar.unix
 
 : get-time ( -- alien )

basis/calendar/windows/windows.factor

@@ -1,5 +1,5 @@
-USING: calendar.backend namespaces alien.c-types system
+USING: calendar namespaces alien.c-types system windows
-windows windows.kernel32 kernel math combinators ;
+windows.kernel32 kernel math combinators ;
 IN: calendar.windows
 
 M: windows gmt-offset ( -- hours minutes seconds )

basis/channels/remote/remote.factor

@@ -4,7 +4,7 @@
 ! Remote Channels
 USING: kernel init namespaces assocs arrays random
 sequences channels match concurrency.messaging
-concurrency.distributed threads ;
+concurrency.distributed threads accessors ;
 IN: channels.remote
 
 <PRIVATE
@@ -52,13 +52,13 @@ TUPLE: remote-channel node id ;
 C: <remote-channel> remote-channel 
 
 M: remote-channel to ( value remote-channel -- )
-    [ [ \ to , remote-channel-id , , ] { } make ] keep
+    [ [ \ to , id>> , , ] { } make ] keep
-    remote-channel-node "remote-channels" <remote-process> 
+    node>> "remote-channels" <remote-process> 
     send-synchronous no-channel = [ no-channel throw ] when ;
 
 M: remote-channel from ( remote-channel -- value )
-    [ [ \ from , remote-channel-id , ] { } make ] keep
+    [ [ \ from , id>> , ] { } make ] keep
-    remote-channel-node "remote-channels" <remote-process> 
+    node>> "remote-channels" <remote-process> 
     send-synchronous dup no-channel = [ no-channel throw ] when* ;
 
 [

basis/cocoa/cocoa-tests.factor

@@ -20,10 +20,10 @@ CLASS: {
 
 test-foo
 
-[ 1 ] [ "x" get NSRect-x ] unit-test
+[ 1.0 ] [ "x" get NSRect-x ] unit-test
-[ 2 ] [ "x" get NSRect-y ] unit-test
+[ 2.0 ] [ "x" get NSRect-y ] unit-test
-[ 101 ] [ "x" get NSRect-w ] unit-test
+[ 101.0 ] [ "x" get NSRect-w ] unit-test
-[ 102 ] [ "x" get NSRect-h ] unit-test
+[ 102.0 ] [ "x" get NSRect-h ] unit-test
 
 CLASS: {
     { +superclass+ "NSObject" }
@@ -41,7 +41,7 @@ Bar [
     -> release
 ] compile-call
 
-[ 1 ] [ "x" get NSRect-x ] unit-test
+[ 1.0 ] [ "x" get NSRect-x ] unit-test
-[ 2 ] [ "x" get NSRect-y ] unit-test
+[ 2.0 ] [ "x" get NSRect-y ] unit-test
-[ 101 ] [ "x" get NSRect-w ] unit-test
+[ 101.0 ] [ "x" get NSRect-w ] unit-test
-[ 102 ] [ "x" get NSRect-h ] unit-test
+[ 102.0 ] [ "x" get NSRect-h ] unit-test

basis/compiler/compiler-docs.factor

@@ -27,7 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler"
 "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
 { $subsection "compiler-usage" }
 { $subsection "compiler-errors" }
-{ $subsection "optimizer" }
+{ $subsection "hints" }
 { $subsection "generator" } ;
 
 ABOUT: "compiler"

basis/compiler/compiler.factor

@@ -43,8 +43,8 @@ SYMBOL: +failed+
     [
         dup crossref?
         [
-            dependencies get
+            dependencies get >alist
-            generic-dependencies get
+            generic-dependencies get >alist
             compiled-xref
         ] [ drop ] if
     ] tri ;

basis/compiler/intrinsics/intrinsics.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes.tuple classes.tuple.private math arrays 
 byte-arrays words stack-checker.known-words ;
-IN: compiler.tree.intrinsics
+IN: compiler.intrinsics
 
 : (tuple) ( layout -- tuple )
     "BUG: missing (tuple) intrinsic" throw ;

basis/compiler/tests/alien.factor

@@ -84,6 +84,13 @@ FUNCTION: tiny ffi_test_17 int x ;
 
 [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
 
+: indirect-test-1' ( ptr -- )
+    "int" { } "cdecl" alien-indirect drop ;
+
+{ 1 0 } [ indirect-test-1' ] must-infer-as
+
+[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
+
 [ -1 indirect-test-1 ] must-fail
 
 : indirect-test-2 ( x y ptr -- result )
@@ -102,7 +109,7 @@ unit-test
 << "f-stdcall" f "stdcall" add-library >>
 
 [ f ] [ "f-stdcall" load-library ] unit-test
-[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
 
 : ffi_test_18 ( w x y z -- int )
     "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }

basis/compiler/tests/optimizer.factor

@@ -210,10 +210,10 @@ USE: binary-search.private
 
 : old-binsearch ( elt quot seq -- elt quot i )
     dup length 1 <= [
-        slice-from
+        from>>
     ] [
         [ midpoint swap call ] 3keep roll dup zero?
-        [ drop dup slice-from swap midpoint@ + ]
+        [ drop dup from>> swap midpoint@ + ]
         [ dup midpoint@ cut-slice old-binsearch ] if
     ] if ; inline
 

basis/compiler/tests/stack-trace.factor

@@ -1,10 +1,10 @@
 IN: compiler.tests
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
-words splitting grouping sorting ;
+words splitting grouping sorting accessors ;
 
 : symbolic-stack-trace ( -- newseq )
-    error-continuation get continuation-call callstack>array
+    error-continuation get call>> callstack>array
     2 group flip first ;
 
 : foo ( -- * ) 3 throw 7 ;

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -229,10 +229,6 @@ M: float detect-float ;
     \ detect-float inlined?
 ] unit-test
 
-[ t ] [
-    [ 3 + = ] \ equal? inlined?
-] unit-test
-
 [ f ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ]
     \ fixnum-shift-fast inlined?

basis/compiler/tree/cleanup/cleanup.factor

@@ -4,8 +4,9 @@ USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
 classes.tuple.private layouts definitions stack-checker.state
-stack-checker.branches compiler.tree
+stack-checker.branches
-compiler.tree.intrinsics
+compiler.intrinsics
+compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.branches ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -81,11 +81,19 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
         drop-values
     ] ;
 
-: drop-dead-outputs ( node -- nodes )
+: drop-dead-outputs ( node -- #shuffle )
     dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
 
+: some-outputs-dead? ( #call -- ? )
+    out-d>> [ live-value? not ] contains? ;
+
+: maybe-drop-dead-outputs ( node -- nodes )
+    dup some-outputs-dead? [
+        dup drop-dead-outputs 2array
+    ] when ;
+
 M: #introduce remove-dead-code* ( #introduce -- nodes )
-    dup drop-dead-outputs 2array ;
+    maybe-drop-dead-outputs ;
 
 M: #>r remove-dead-code*
     [ filter-live ] change-out-r
@@ -110,17 +118,9 @@ M: #push remove-dead-code*
     [ in-d>> #drop remove-dead-code* ]
     bi ;
 
-: some-outputs-dead? ( #call -- ? )
-    out-d>> [ live-value? not ] contains? ;
-
 M: #call remove-dead-code*
-    dup dead-flushable-call? [
+    dup dead-flushable-call?
-        remove-flushable-call
+    [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
-    ] [
-        dup some-outputs-dead? [
-            dup drop-dead-outputs 2array
-        ] when
-    ] if ;
 
 M: #shuffle remove-dead-code*
     [ filter-live ] change-in-d
@@ -136,3 +136,9 @@ M: #copy remove-dead-code*
 M: #terminate remove-dead-code*
     [ filter-live ] change-in-d
     [ filter-live ] change-in-r ;
+
+M: #alien-invoke remove-dead-code*
+    maybe-drop-dead-outputs ;
+
+M: #alien-indirect remove-dead-code*
+    maybe-drop-dead-outputs ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
-compiler.tree.intrinsics namespaces compiler.tree.propagation.info
+compiler.intrinsics namespaces compiler.tree.propagation.info
 stack-checker.errors kernel.private ;
 
 \ escape-analysis must-infer

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -4,8 +4,8 @@ USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
 combinators deques search-deques namespaces fry classes
 classes.algebra stack-checker.state
+compiler.intrinsics
 compiler.tree
-compiler.tree.intrinsics
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
@@ -23,9 +23,8 @@ DEFER: record-literal-allocation
     [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
 
 : object-slots ( object -- slots/f )
-    #! Delegation
     {
-        { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
+        { [ dup class immutable-tuple-class? ] [ tuple-slots ] }
         { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
         [ drop f ]
     } cond ;
@@ -37,7 +36,6 @@ DEFER: record-literal-allocation
     if* ;
 
 M: #push escape-analysis*
-    #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
 : record-unknown-allocation ( #call -- )
@@ -59,7 +57,7 @@ M: #push escape-analysis*
     [ second node-value-info literal>> ] 2bi
     dup fixnum? [
         {
-            { [ over tuple class<= ] [ 3 - ] }
+            { [ over tuple class<= ] [ 2 - ] }
             { [ over complex class<= ] [ 1 - ] }
             [ drop f ]
         } cond nip

basis/compiler/tree/finalization/finalization.factor

@@ -1,9 +1,32 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences
+USING: kernel arrays accessors sequences sequences.private words
-compiler.tree compiler.tree.combinators ;
+fry namespaces math math.order memoize classes.builtin
+classes.tuple.private slots.private combinators layouts
+byte-arrays alien.accessors
+compiler.intrinsics
+compiler.tree
+compiler.tree.builder
+compiler.tree.normalization
+compiler.tree.propagation
+compiler.tree.propagation.info
+compiler.tree.cleanup
+compiler.tree.def-use
+compiler.tree.dead-code
+compiler.tree.combinators ;
 IN: compiler.tree.finalization
 
+! This pass runs after propagation, so that it can expand
+! built-in type predicates and memory allocation; these cannot
+! be expanded before propagation since we need to see 'fixnum?'
+! instead of 'tag 0 eq?' and so on, for semantic reasoning.
+! We also delete empty stack shuffles and copies to facilitate
+! tail call optimization in the code generator. After this pass
+! runs, stack flow information is no longer accurate, since we
+! punt in 'splice-quot' and don't update everything that we
+! should; this simplifies the code, improves performance, and we
+! don't need the stack flow information after this pass anyway.
+
 GENERIC: finalize* ( node -- nodes )
 
 M: #copy finalize* drop f ;
@@ -13,6 +36,92 @@ M: #shuffle finalize*
     [ in>> ] [ out>> ] bi sequence=
     [ drop f ] when ;
 
+: splice-quot ( quot -- nodes )
+    [
+        build-tree
+        normalize
+        propagate
+        cleanup
+        compute-def-use
+        remove-dead-code
+        but-last
+    ] with-scope ;
+
+: builtin-predicate? ( #call -- ? )
+    word>> "predicating" word-prop builtin-class? ;
+
+MEMO: builtin-predicate-expansion ( word -- nodes )
+    def>> splice-quot ;
+
+: expand-builtin-predicate ( #call -- nodes )
+    word>> builtin-predicate-expansion ;
+
+: first-literal ( #call -- obj ) node-input-infos first literal>> ;
+
+: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
+
+: expand-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        last-literal tuple-layout?
+    ] [ drop f ] if ;
+
+MEMO: (tuple-boa-expansion) ( n -- quot )
+    [
+        [ 2 + ] map <reversed>
+        [ '[ [ , set-slot ] keep ] % ] each
+    ] [ ] make ;
+
+: tuple-boa-expansion ( layout -- quot )
+    #! No memoization here since otherwise we'd hang on to
+    #! tuple layout objects.
+    size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
+
+: expand-tuple-boa ( #call -- node )
+    last-literal tuple-boa-expansion ;
+
+MEMO: <array>-expansion ( n -- quot )
+    [
+        [ swap (array) ] %
+        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        \ nip ,
+    ] [ ] make splice-quot ;
+
+: expand-<array>? ( #call -- ? )
+    dup word>> \ <array> eq? [
+        first-literal dup integer?
+        [ 0 32 between? ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+    first-literal <array>-expansion ;
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+MEMO: <byte-array>-expansion ( n -- quot )
+    [
+        [ (byte-array) ] %
+        bytes>cells [ cell * ] map
+        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+    ] [ ] make splice-quot ;
+
+: expand-<byte-array>? ( #call -- ? )
+    dup word>> \ <byte-array> eq? [
+        first-literal dup integer?
+        [ 0 128 between? ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- nodes )
+    first-literal <byte-array>-expansion ;
+
+M: #call finalize*
+    {
+        { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
+        { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
+        { [ dup expand-<array>? ] [ expand-<array> ] }
+        { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
+        [ ]
+    } cond ;
+
 M: node finalize* ;
 
 : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

basis/compiler/tree/propagation/info/info.factor

@@ -12,8 +12,6 @@ IN: compiler.tree.propagation.info
 
 : null-class? ( class -- ? ) null class<= ;
 
-SYMBOL: +interval+
-
 GENERIC: eql? ( obj1 obj2 -- ? )
 M: object eql? eq? ;
 M: fixnum eql? eq? ;
@@ -40,7 +38,7 @@ slots ;
 
 : class-interval ( class -- interval )
     dup real class<=
-    [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
+    [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
 
 : interval>literal ( class interval -- literal literal? )
     #! If interval has zero length and the class is sufficiently
@@ -61,10 +59,34 @@ slots ;
 
 : <value-info> ( -- info ) \ value-info new ;
 
+: read-only-slots ( values class -- slots )
+    all-slots
+    [ read-only>> [ drop f ] unless ] 2map
+    f prefix ;
+
+DEFER: <literal-info>
+
+: init-literal-info ( info -- info )
+    dup literal>> class >>class
+    dup literal>> dup real? [ [a,a] >>interval ] [
+        [ [-inf,inf] >>interval ] dip
+        {
+            { [ dup complex? ] [
+                [ real-part <literal-info> ]
+                [ imaginary-part <literal-info> ] bi
+                2array >>slots
+            ] }
+            { [ dup tuple? ] [
+                [ tuple-slots [ <literal-info> ] map ] [ class ] bi
+                read-only-slots >>slots
+            ] }
+            [ drop ]
+        } cond
+    ] if ; inline
+
 : init-value-info ( info -- info )
     dup literal?>> [
-        dup literal>> class >>class
+        init-literal-info
-        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
     ] [
         dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
             null >>class
@@ -75,7 +97,7 @@ slots ;
             dup [ class>> ] [ interval>> ] bi interval>literal
             [ >>literal ] [ >>literal? ] bi*
         ] if
-    ] if ;
+    ] if ; inline
 
 : <class/interval-info> ( class interval -- info )
     <value-info>
@@ -84,7 +106,7 @@ slots ;
     init-value-info ; foldable
 
 : <class-info> ( class -- info )
-    dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
+    dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
     <class/interval-info> ; foldable
 
 : <interval-info> ( interval -- info )

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

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard classes.algebra
+math.partial-dispatch generic generic.standard generic.math
-classes.union sets quotations assocs combinators words
+classes.algebra classes.union sets quotations assocs combinators
-namespaces
+words namespaces
 compiler.tree
 compiler.tree.builder
 compiler.tree.normalization
@@ -145,3 +145,13 @@ SYMBOL: history
 
 : always-inline-word? ( word -- ? )
     { curry compose } memq? ;
+
+: do-inlining ( #call word -- ? )
+    {
+        { [ dup always-inline-word? ] [ inline-word ] }
+        { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
+        { [ dup math-partial? ] [ inline-math-partial ] }
+        { [ dup method-body? ] [ inline-method-body ] }
+        [ 2drop f ]
+    } cond ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -7,6 +7,7 @@ classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
 definitions
 stack-checker.state
+compiler.intrinsics
 compiler.tree.comparisons
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -17,11 +18,11 @@ IN: compiler.tree.propagation.known-words
 
 \ fixnum
 most-negative-fixnum most-positive-fixnum [a,b]
-+interval+ set-word-prop
+"interval" set-word-prop
 
 \ array-capacity
 0 max-array-capacity [a,b]
-+interval+ set-word-prop
+"interval" set-word-prop
 
 { + - * / }
 [ { number number } "input-classes" set-word-prop ] each
@@ -66,17 +67,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
     over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
 
 { bitnot fixnum-bitnot bignum-bitnot } [
-    [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop
+    [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
 ] each
 
-\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
+\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
 
 : math-closure ( class -- newclass )
     { fixnum bignum integer rational float real number object }
     [ class<= ] with find nip ;
 
 : fits? ( interval class -- ? )
-    +interval+ word-prop interval-subset? ;
+    "interval" word-prop interval-subset? ;
 
 : binary-op-class ( info1 info2 -- newclass )
     [ class>> ] bi@
@@ -120,7 +121,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ binary-op-class ] [ , binary-op-interval ] 2bi
         @
         <class/interval-info>
-    ] +outputs+ set-word-prop ;
+    ] "outputs" set-word-prop ;
 
 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
@@ -158,7 +159,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
 
 : define-comparison-constraints ( word op -- )
-    '[ , comparison-constraints ] +constraints+ set-word-prop ;
+    '[ , comparison-constraints ] "constraints" set-word-prop ;
 
 comparison-ops
 [ dup '[ , define-comparison-constraints ] each-derived-op ] each
@@ -178,13 +179,13 @@ generic-comparison-ops [
 
 comparison-ops [
     dup '[
-        [ , fold-comparison ] +outputs+ set-word-prop
+        [ , fold-comparison ] "outputs" set-word-prop
     ] each-derived-op
 ] each
 
 generic-comparison-ops [
     dup specific-comparison
-    '[ , fold-comparison ] +outputs+ set-word-prop
+    '[ , fold-comparison ] "outputs" set-word-prop
 ] each
 
 : maybe-or-never ( ? -- info )
@@ -196,7 +197,7 @@ generic-comparison-ops [
 { number= bignum= float= } [
     [
         info-intervals-intersect? maybe-or-never
-    ] +outputs+ set-word-prop
+    ] "outputs" set-word-prop
 ] each
 
 : info-classes-intersect? ( info1 info2 -- ? )
@@ -206,13 +207,13 @@ generic-comparison-ops [
     over value-info literal>> fixnum? [
         [ value-info literal>> is-equal-to ] dip t-->
     ] [ 3drop f ] if
-] +constraints+ set-word-prop
+] "constraints" set-word-prop
 
 \ eq? [
     [ info-intervals-intersect? ]
     [ info-classes-intersect? ]
-    2bi or maybe-or-never
+    2bi and maybe-or-never
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
 
 {
     { >fixnum fixnum }
@@ -226,7 +227,7 @@ generic-comparison-ops [
             interval-intersect
         ] 2bi
         <class/interval-info>
-    ] +outputs+ set-word-prop
+    ] "outputs" set-word-prop
 ] assoc-each
 
 {
@@ -250,36 +251,36 @@ generic-comparison-ops [
         }
     } cond
     [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
-    [ 2nip ] curry +outputs+ set-word-prop
+    [ 2nip ] curry "outputs" set-word-prop
 ] each
 
-{ <tuple> <tuple-boa> } [
+{ <tuple> <tuple-boa> (tuple) } [
     [
         literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
         [ clear ] dip
-    ] +outputs+ set-word-prop
+    ] "outputs" set-word-prop
 ] each
 
 \ new [
     literal>> dup tuple-class? [ drop tuple ] unless <class-info>
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
 
 ! the output of clone has the same type as the input
 { clone (clone) } [
     [ clone f >>literal f >>literal? ]
-    +outputs+ set-word-prop
+    "outputs" set-word-prop
 ] each
 
 \ slot [
     dup literal?>>
     [ literal>> swap value-info-slot ] [ 2drop object-info ] if
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
 
 \ instance? [
     [ value-info ] dip over literal>> class? [
         [ literal>> ] dip predicate-constraints
     ] [ 3drop f ] if
-] +constraints+ set-word-prop
+] "constraints" set-word-prop
 
 \ instance? [
     ! We need to force the caller word to recompile when the class
@@ -292,4 +293,4 @@ generic-comparison-ops [
         [ predicate-output-infos ]
         bi
     ] [ 2drop object-info ] if
-] +outputs+ set-word-prop
+] "outputs" set-word-prop

basis/compiler/tree/propagation/nodes/nodes.factor

@@ -6,9 +6,6 @@ compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
-SYMBOL: +constraints+
-SYMBOL: +outputs+
-
 GENERIC: propagate-before ( node -- )
 
 GENERIC: propagate-after ( node -- )

basis/compiler/tree/propagation/propagation-tests.factor

@@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     ] final-classes
 ] unit-test
 
+[ V{ integer array } ] [
+    [
+        [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
+        [ { array } declare mixed-mutable-immutable boa ] if
+        [ x>> ] [ y>> ] bi
+    ] final-classes
+] unit-test
+
 ! Recursive propagation
 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 
@@ -573,6 +581,18 @@ MIXIN: empty-mixin
 
 [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
 
+[ V{ float } ] [
+    [
+        [ { float float } declare <complex> ]
+        [ 2drop C{ 0.0 0.0 } ]
+        if real-part
+    ] final-classes
+] unit-test
+
+[ V{ POSTPONE: f } ] [
+    [ { float } declare 0 eq? ] final-classes
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -3,8 +3,7 @@
 USING: fry accessors kernel sequences sequences.private assocs words
 namespaces classes.algebra combinators classes classes.tuple
 classes.tuple.private continuations arrays
-math math.partial-dispatch math.private slots generic definitions
+math math.private slots generic definitions
-generic.standard generic.math
 stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
@@ -52,7 +51,7 @@ M: #declare propagate-before
     with-datastack first assume ;
 
 : compute-constraints ( #call word -- )
-    dup +constraints+ word-prop [ nip custom-constraints ] [
+    dup "constraints" word-prop [ nip custom-constraints ] [
         dup predicate? [
             [ [ in-d>> first ] [ out-d>> first ] bi ]
             [ "predicating" word-prop ] bi*
@@ -61,19 +60,22 @@ M: #declare propagate-before
     ] if* ;
 
 : call-outputs-quot ( #call word -- infos )
-    [ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
+    [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
     with-datastack ;
 
 : foldable-call? ( #call word -- ? )
     "foldable" word-prop
     [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
 
-: fold-call ( #call word -- infos )
+: (fold-call) ( #call word -- info )
     [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
     '[ , , with-datastack [ <literal-info> ] map nip ]
     [ drop [ object-info ] replicate ]
     recover ;
 
+: fold-call ( #call word -- )
+    [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
+
 : predicate-output-infos ( info class -- info )
     [ class>> ] dip {
         { [ 2dup class<= ] [ t <literal-info> ] }
@@ -95,30 +97,23 @@ M: #declare propagate-before
 
 : output-value-infos ( #call word -- infos )
     {
-        { [ 2dup foldable-call? ] [ fold-call ] }
         { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
         { [ dup predicate? ] [ propagate-predicate ] }
-        { [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
+        { [ dup "outputs" word-prop ] [ call-outputs-quot ] }
         [ default-output-value-infos ]
     } cond ;
 
-: do-inlining ( #call word -- ? )
-    {
-        { [ dup always-inline-word? ] [ inline-word ] }
-        { [ dup standard-generic? ] [ inline-standard-method ] }
-        { [ dup math-generic? ] [ inline-math-method ] }
-        { [ dup math-partial? ] [ inline-math-partial ] }
-        { [ dup method-body? ] [ inline-method-body ] }
-        [ 2drop f ]
-    } cond ;
-
 M: #call propagate-before
-    dup word>> 2dup do-inlining [ 2drop ] [
+    dup word>> {
+        { [ 2dup foldable-call? ] [ fold-call ] }
+        { [ 2dup do-inlining ] [ 2drop ] }
+        [
             [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
             [ compute-constraints ]
             2bi
-    ] if ;
+        ]
+    } cond ;
 
 M: #call annotate-node
     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;

basis/compiler/tree/propagation/slots/slots.factor

@@ -31,26 +31,19 @@ UNION: fixed-length-sequence array byte-array string ;
 : tuple-constructor? ( word -- ? )
     { <tuple-boa> <complex> } memq? ;
 
-: read-only-slots ( values class -- slots )
-    #! Delegation.
-    all-slots rest-slice
-    [ read-only>> [ drop f ] unless ] 2map
-    { f f } prepend ;
-
 : fold-<tuple-boa> ( values class -- info )
-    [ , f , [ literal>> ] map % ] { } make >tuple
+    [ [ literal>> ] map ] dip prefix >tuple
     <literal-info> ;
 
 : (propagate-tuple-constructor) ( values class -- info )
     [ [ value-info ] map ] dip [ read-only-slots ] keep
-    over 2 tail-slice [ dup [ literal?>> ] when ] all? [
+    over rest-slice [ dup [ literal?>> ] when ] all? [
-        [ 2 tail-slice ] dip fold-<tuple-boa>
+        [ rest-slice ] dip fold-<tuple-boa>
     ] [
         <tuple-info>
     ] if ;
 
 : propagate-<tuple-boa> ( #call -- info )
-    #! Delegation
     in-d>> unclip-last
     value-info literal>> class>> (propagate-tuple-constructor) ;
 
@@ -75,7 +68,6 @@ UNION: fixed-length-sequence array byte-array string ;
     [ 1 = ] [ length>> ] bi* and ;
 
 : value-info-slot ( slot info -- info' )
-    #! Delegation.
     {
         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
         { [ 2dup length-accessor? ] [ nip length>> ] }

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -30,7 +30,7 @@ TUPLE: empty-tuple ;
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
     [ 2 cons boa { [ ] [ ] } dispatch ]
     [ dup [ drop f ] [ "A" throw ] if ]
-    [ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
+    [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
     [ [ ] [ ] curry curry call ]
     [ <complex> <complex> dup 1 slot drop 2 slot drop ]
     [ 1 cons boa over [ "A" throw ] when car>> ]

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -4,8 +4,8 @@ USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
 stack-checker.branches
+compiler.intrinsics
 compiler.tree
-compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.simple

basis/concurrency/distributed/distributed.factor

@@ -37,7 +37,7 @@ M: remote-process send ( message thread -- )
     send-remote-message ;
 
 M: thread (serialize) ( obj -- )
-    thread-id local-node get-global <remote-process>
+    id>> local-node get-global <remote-process>
     (serialize) ;
 
 : stop-node ( node -- )

basis/cpu/ppc/architecture/architecture.factor

@@ -18,13 +18,13 @@ IN: cpu.ppc.architecture
 : ds-reg 14 ; inline
 : rs-reg 15 ; inline
 
-: reserved-area-size
+: reserved-area-size ( -- n )
     os {
         { linux [ 2 ] }
         { macosx [ 6 ] }
     } case cells ; foldable
 
-: lr-save
+: lr-save ( -- n )
     os {
         { linux [ 1 ] }
         { macosx [ 2 ] }
@@ -32,12 +32,12 @@ IN: cpu.ppc.architecture
 
 : param@ ( n -- x ) reserved-area-size + ; inline
 
-: param-save-size 8 cells ; foldable
+: param-save-size ( -- n ) 8 cells ; foldable
 
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size 2 cells ;
+: factor-area-size ( -- n ) 2 cells ; foldable
 
 : next-save ( n -- i ) cell - ;
 
@@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- )
     1 1 rot ADDI
     0 MTLR ;
 
-: (%call) 11 MTLR BLRL ;
+: (%call) ( -- ) 11 MTLR BLRL ;
 
-: (%jump) 11 MTCTR BCTR ;
+: (%jump) ( -- ) 11 MTCTR BCTR ;
 
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
@@ -218,7 +218,7 @@ M: ppc %box-long-long ( n func -- )
         4 1 rot cell + local@ LWZ
     ] when* r> f %alien-invoke ;
 
-: temp@ stack-frame* factor-area-size - swap - ;
+: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
 
 : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
 

basis/cpu/ppc/intrinsics/intrinsics.factor

@@ -4,24 +4,28 @@ USING: accessors alien alien.accessors alien.c-types arrays
 cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
 cpu.architecture kernel kernel.private math math.private
 namespaces sequences words generic quotations byte-arrays
-hashtables hashtables.private compiler.generator
+hashtables hashtables.private
-compiler.generator.registers compiler.generator.fixup
 sequences.private sbufs vectors system layouts
-math.floats.private classes slots.private combinators
+math.floats.private classes slots.private
-compiler.constants ;
+combinators
+compiler.constants
+compiler.intrinsics
+compiler.generator
+compiler.generator.fixup
+compiler.generator.registers ;
 IN: cpu.ppc.intrinsics
 
-: %slot-literal-known-tag
+: %slot-literal-known-tag ( -- out value offset )
     "val" operand
     "obj" operand
     "n" get cells
     "obj" get operand-tag - ;
 
-: %slot-literal-any-tag
+: %slot-literal-any-tag ( -- out value offset )
     "obj" operand "scratch1" operand %untag
     "val" operand "scratch1" operand "n" get cells ;
 
-: %slot-any
+: %slot-any ( -- out value offset )
     "obj" operand "scratch1" operand %untag
     "offset" operand "n" operand 1 SRAWI
     "scratch1" operand "val" operand "offset" operand ;
@@ -188,7 +192,7 @@ IN: cpu.ppc.intrinsics
     }
 } define-intrinsics
 
-: generate-fixnum-mod
+: generate-fixnum-mod ( -- )
     #! PowerPC doesn't have a MOD instruction; so we compute
     #! x-(x/y)*y. Puts the result in "s" operand.
     "s" operand "r" operand "y" operand MULLW
@@ -259,7 +263,7 @@ IN: cpu.ppc.intrinsics
 \ fixnum+ \ ADD \ ADDO. overflow-template
 \ fixnum- \ SUBF \ SUBFO. overflow-template
 
-: generate-fixnum/i
+: generate-fixnum/i ( -- )
     #! This VOP is funny. If there is an overflow, it falls
     #! through to the end, and the result is in "x" operand.
     #! Otherwise it jumps to the "no-overflow" label and the
@@ -437,44 +441,44 @@ IN: cpu.ppc.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-! \ (tuple) [
+\ (tuple) [
-!     tuple "layout" get size>> 2 + cells %allot
+    tuple "layout" get size>> 2 + cells %allot
-!     ! Store layout
+    ! Store layout
-!     "layout" get 12 load-indirect
+    "layout" get 12 load-indirect
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "tuple" get tuple %store-tagged
+    "tuple" get tuple %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
-!     { +scratch+ { { f "tuple" } } }
+    { +scratch+ { { f "tuple" } } }
-!     { +output+ { "tuple" } }
+    { +output+ { "tuple" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (array) [
+\ (array) [
-!     array "n" get 2 + cells %allot
+    array "n" get 2 + cells %allot
-!     ! Store length
+    ! Store length
-!     "n" operand 12 LI
+    "n" operand 12 LI
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "array" get object %store-tagged
+    "array" get object %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (byte-array) [
+\ (byte-array) [
-!     byte-array "n" get 2 cells + %allot
+    byte-array "n" get 2 cells + %allot
-!     ! Store length
+    ! Store length
-!     "n" operand 12 LI
+    "n" operand 12 LI
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "array" get object %store-tagged
+    "array" get object %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
 
 \ <ratio> [
     ratio 3 cells %allot
@@ -514,8 +518,8 @@ IN: cpu.ppc.intrinsics
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum
-    "offset" operand dup "alien" operand ADD
+    "scratch" operand "offset" operand "alien" operand ADD
-    "value" operand "offset" operand 0 roll call ; inline
+    "value" operand "scratch" operand 0 roll call ; inline
 
 : alien-integer-get-template
     H{
@@ -523,7 +527,7 @@ IN: cpu.ppc.intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "value" } } }
+        { +scratch+ { { f "value" } { f "scratch" } } }
         { +output+ { "value" } }
         { +clobber+ { "offset" } }
     } ;
@@ -539,6 +543,7 @@ IN: cpu.ppc.intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
+        { +scratch+ { { f "scratch" } } }
         { +clobber+ { "value" "offset" } }
     } ;
 
@@ -579,7 +584,7 @@ define-alien-integer-intrinsics
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }
-    { +scratch+ { { unboxed-alien "value" } } }
+    { +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
     { +output+ { "value" } }
     { +clobber+ { "offset" } }
 } define-intrinsic
@@ -592,6 +597,7 @@ define-alien-integer-intrinsics
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }
+    { +scratch+ { { f "scratch" } } }
     { +clobber+ { "offset" } }
 } define-intrinsic
 
@@ -601,7 +607,7 @@ define-alien-integer-intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { float "value" } } }
+        { +scratch+ { { float "value" } { f "scratch" } } }
         { +output+ { "value" } }
         { +clobber+ { "offset" } }
     } ;
@@ -613,6 +619,7 @@ define-alien-integer-intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
+        { +scratch+ { { f "scratch" } } }
         { +clobber+ { "offset" } }
     } ;
 

basis/cpu/x86/64/64.factor

@@ -178,7 +178,7 @@ stack-params "__stack_value" c-type (>>reg-class) >>
 
 : struct-types&offset ( struct-type -- pairs )
     fields>> [
-        [ class>> ] [ offset>> ] bi 2array
+        [ type>> ] [ offset>> ] bi 2array
     ] map ;
 
 : split-struct ( pairs -- seq )

basis/cpu/x86/intrinsics/intrinsics.factor

@@ -4,10 +4,14 @@ USING: accessors alien alien.accessors arrays cpu.x86.assembler
 cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
 kernel.private math math.private namespaces quotations sequences
 words generic byte-arrays hashtables hashtables.private
-compiler.generator compiler.generator.registers
+sequences.private sbufs sbufs.private
-compiler.generator.fixup sequences.private sbufs sbufs.private
 vectors vectors.private layouts system strings.private
-slots.private compiler.constants ;
+slots.private 
+compiler.constants
+compiler.intrinsics
+compiler.generator
+compiler.generator.fixup
+compiler.generator.registers ;
 IN: cpu.x86.intrinsics
 
 ! Type checks
@@ -289,45 +293,45 @@ IN: cpu.x86.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-! \ (tuple) [
+\ (tuple) [
-!     tuple "layout" get size>> 2 + cells [
+    tuple "layout" get size>> 2 + cells [
-!         ! Store layout
+        ! Store layout
-!         "layout" get "scratch" get load-literal
+        "layout" get "scratch" get load-literal
-!         1 object@ "scratch" operand MOV
+        1 object@ "scratch" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "tuple" get tuple %store-tagged
+        "tuple" get tuple %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
-!     { +scratch+ { { f "tuple" } { f "scratch" } } }
+    { +scratch+ { { f "tuple" } { f "scratch" } } }
-!     { +output+ { "tuple" } }
+    { +output+ { "tuple" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (array) [
+\ (array) [
-!     array "n" get 2 + cells [
+    array "n" get 2 + cells [
-!         ! Store length
+        ! Store length
-!         1 object@ "n" operand MOV
+        1 object@ "n" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "array" get object %store-tagged
+        "array" get object %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (byte-array) [
+\ (byte-array) [
-!     byte-array "n" get 2 cells + [
+    byte-array "n" get 2 cells + [
-!         ! Store length
+        ! Store length
-!         1 object@ "n" operand MOV
+        1 object@ "n" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "array" get object %store-tagged
+        "array" get object %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
 
 \ <ratio> [
     ratio 3 cells [

basis/db/db-tests.factor

@@ -1,5 +1,5 @@
-IN: db.tests
 USING: tools.test db kernel ;
+IN: db.tests
 
 { 1 0 } [ [ drop ] query-each ] must-infer-as
 { 1 1 } [ [ ] query-map ] must-infer-as

basis/db/db.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes continuations destructors kernel math
 namespaces sequences sequences.lib classes.tuple words strings
-tools.walker accessors combinators.lib ;
+tools.walker accessors combinators.lib combinators ;
 IN: db
 
 TUPLE: db
@@ -15,24 +15,25 @@ TUPLE: db
     new
         H{ } clone >>insert-statements
         H{ } clone >>update-statements
-        H{ } clone >>delete-statements ;
+        H{ } clone >>delete-statements ; inline
 
-GENERIC: make-db* ( seq class -- db )
+GENERIC: make-db* ( seq db -- db )
 
-: make-db ( seq class -- db )
+: make-db ( seq class -- db ) new-db make-db* ;
-    new-db make-db* ;
 
 GENERIC: db-open ( db -- db )
 HOOK: db-close db ( handle -- )
 
 : dispose-statements ( assoc -- ) values dispose-each ;
 
-: dispose-db ( db -- ) 
+: db-dispose ( db -- ) 
     dup db [
-        dup insert-statements>> dispose-statements
+        {
-        dup update-statements>> dispose-statements
+            [ insert-statements>> dispose-statements ]
-        dup delete-statements>> dispose-statements
+            [ update-statements>> dispose-statements ]
-        handle>> db-close
+            [ delete-statements>> dispose-statements ]
+            [ handle>> db-close ]
+        } cleave
     ] with-variable ;
 
 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
@@ -47,8 +48,8 @@ TUPLE: result-set sql in-params out-params handle n max ;
         swap >>in-params
         swap >>sql ;
 
-HOOK: <simple-statement> db ( str in out -- statement )
+HOOK: <simple-statement> db ( string in out -- statement )
-HOOK: <prepared-statement> db ( str in out -- statement )
+HOOK: <prepared-statement> db ( string in out -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( statement -- )
 GENERIC: low-level-bind ( statement -- )

basis/db/errors/errors.factor

@@ -6,6 +6,5 @@ IN: db.errors
 ERROR: db-error ;
 ERROR: sql-error ;
 
-
 ERROR: table-exists ;
 ERROR: bad-schema ;

basis/db/pools/pools-tests.factor

@@ -13,7 +13,7 @@ USE: db.sqlite
 
 [ "pool-test.db" temp-file delete-file ] ignore-errors
 
-[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
+[ ] [ "pool-test.db" temp-file sqlite-db <db-pool> "pool" set ] unit-test
 
 [ ] [ "pool" get expired>> t >>expired drop ] unit-test
 

basis/db/postgresql/postgresql.factor

@@ -16,7 +16,7 @@ TUPLE: postgresql-statement < statement ;
 
 TUPLE: postgresql-result-set < result-set ;
 
-M: postgresql-db make-db* ( seq tuple -- db )
+M: postgresql-db make-db* ( seq db -- db )
     >r first4 r>
         swap >>db
         swap >>pass

basis/db/queries/queries.factor

@@ -43,13 +43,6 @@ M: random-id-generator eval-generator ( singleton -- obj )
 : interval-comparison ( ? str -- str )
     "from" = " >" " <" ? swap [ "= " append ] when ;
 
-: fp-infinity? ( float -- ? )
-    dup float? [
-        double>bits -52 shift 11 2^ 1- [ bitand ] keep =
-    ] [
-        drop f
-    ] if ;
-
 : (infinite-interval?) ( interval -- ?1 ?2 )
     [ from>> ] [ to>> ] bi
     [ first fp-infinity? ] bi@ ;

basis/db/sqlite/ffi/ffi.factor

@@ -118,6 +118,7 @@ FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int
 FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
 FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
 FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
+! Bind the same function as above, but for unsigned 64bit integers
 : sqlite3-bind-uint64 ( pStmt index in64 -- int )
     "int" "sqlite" "sqlite3_bind_int64"
     { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
@@ -131,6 +132,7 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+! Bind the same function as above, but for unsigned 64bit integers
 : sqlite3-column-uint64 ( pStmt col -- uint64 )
     "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
     { "sqlite3_stmt*" "int" } alien-invoke ;

basis/db/sqlite/sqlite-tests.factor

@@ -57,8 +57,7 @@ IN: db.sqlite.tests
     ] with-db
 ] unit-test
 
-[
+[ ] [
-] [
     test.db [
         [
             "insert into person(name, country) values('Jose', 'Mexico')"

basis/db/sqlite/sqlite.factor

@@ -19,7 +19,7 @@ M: sqlite-db db-open ( db -- db )
     dup path>> sqlite-open >>handle ;
 
 M: sqlite-db db-close ( handle -- ) sqlite-close ;
-M: sqlite-db dispose ( db -- ) dispose-db ;
+M: sqlite-db dispose ( db -- ) db-dispose ;
 
 TUPLE: sqlite-statement < statement ;
 
@@ -52,12 +52,12 @@ M: sqlite-result-set dispose ( result-set -- )
     handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
 
 M: sqlite-statement low-level-bind ( statement -- )
-    [ statement-bind-params ] [ statement-handle ] bi
+    [ bind-params>> ] [ handle>> ] bi
     [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
 
 M: sqlite-statement bind-statement* ( statement -- )
     sqlite-maybe-prepare
-    dup statement-bound? [ dup reset-bindings ] when
+    dup bound?>> [ dup reset-bindings ] when
     low-level-bind ;
 
 GENERIC: sqlite-bind-conversion ( tuple obj -- array )

basis/db/tuples/tuples-tests.factor

@@ -41,9 +41,9 @@ SYMBOL: person4
     
     [ ] [ person1 get insert-tuple ] unit-test
 
-    [ 1 ] [ person1 get person-the-id ] unit-test
+    [ 1 ] [ person1 get the-id>> ] unit-test
 
-    [ ] [ 200 person1 get set-person-the-number ] unit-test
+    [ ] [ person1 get 200 >>the-number drop ] unit-test
 
     [ ] [ person1 get update-tuple ] unit-test
 

basis/db/types/types.factor

@@ -8,7 +8,7 @@ classes.singleton accessors quotations random ;
 IN: db.types
 
 HOOK: persistent-table db ( -- hash )
-HOOK: compound db ( str obj -- hash )
+HOOK: compound db ( string obj -- hash )
 
 TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
 
@@ -78,7 +78,7 @@ FACTOR-BLOB NULL URL ;
         swap >>class
     dup normalize-spec ;
 
-: number>string* ( n/str -- str )
+: number>string* ( n/string -- string )
     dup number? [ number>string ] when ;
 
 : remove-db-assigned-id ( specs -- obj )
@@ -97,7 +97,7 @@ FACTOR-BLOB NULL URL ;
 
 ERROR: unknown-modifier ;
 
-: lookup-modifier ( obj -- str )
+: lookup-modifier ( obj -- string )
     {
         { [ dup array? ] [ unclip lookup-modifier swap compound ] }
         [ persistent-table at* [ unknown-modifier ] unless third ]
@@ -105,43 +105,43 @@ ERROR: unknown-modifier ;
 
 ERROR: no-sql-type ;
 
-: (lookup-type) ( obj -- str )
+: (lookup-type) ( obj -- string )
     persistent-table at* [ no-sql-type ] unless ;
 
-: lookup-type ( obj -- str )
+: lookup-type ( obj -- string )
     dup array? [
         unclip (lookup-type) first nip
     ] [
         (lookup-type) first
     ] if ;
 
-: lookup-create-type ( obj -- str )
+: lookup-create-type ( obj -- string )
     dup array? [
         unclip (lookup-type) second swap compound
     ] [
         (lookup-type) second
     ] if ;
 
-: single-quote ( str -- newstr )
+: single-quote ( string -- new-string )
     "'" swap "'" 3append ;
 
-: double-quote ( str -- newstr )
+: double-quote ( string -- new-string )
     "\"" swap "\"" 3append ;
 
-: paren ( str -- newstr )
+: paren ( string -- new-string )
     "(" swap ")" 3append ;
 
-: join-space ( str1 str2 -- newstr )
+: join-space ( string1 string2 -- new-string )
     " " swap 3append ;
 
-: modifiers ( spec -- str )
+: modifiers ( spec -- string )
     modifiers>> [ lookup-modifier ] map " " join
     dup empty? [ " " prepend ] unless ;
 
 HOOK: bind% db ( spec -- )
 HOOK: bind# db ( spec obj -- )
 
-: offset-of-slot ( str obj -- n )
+: offset-of-slot ( string obj -- n )
     class superclasses [ "slots" word-prop ] map concat
     slot-named offset>> ;
 

basis/debugger/debugger-docs.factor

@@ -1,7 +1,7 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system debugger.private
+help generic.standard continuations system io.files.private
-io.files.private listener ;
+listener ;
 IN: debugger
 
 ARTICLE: "debugger" "The debugger"
@@ -22,8 +22,6 @@ ARTICLE: "debugger" "The debugger"
 { $subsection :2 }
 { $subsection :3 }
 { $subsection :res }
-"Assertions:"
-{ $subsection "errors-assert" }
 "You can read more about error handling in " { $link "errors" } "." ;
 
 ABOUT: "debugger"

basis/debugger/threads/threads.factor

@@ -10,14 +10,17 @@ IN: debugger.threads
         dup id>> #
         " (" % dup name>> %
         ", " % dup quot>> unparse-short % ")" %
-    ] "" make swap write-object ":" print nl ;
+    ] "" make swap write-object ":" print ;
 
 M: thread error-in-thread ( error thread -- )
     initial-thread get-global eq? [
         die drop
     ] [
         global [
-            error-thread get-global error-in-thread. print-error flush
+            error-thread get-global error-in-thread. nl
+            print-error nl
+            :c
+            flush
         ] bind
     ] if ;
 

basis/delegate/delegate-tests.factor

@@ -15,7 +15,7 @@ GENERIC# whoa 1 ( s t -- w )
 PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
 
 : hello-test ( hello/goodbye -- array )
-    [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
+    [ hello? ] [ this>> ] [ that>> ] tri 3array ;
 
 CONSULT: baz goodbye these>> ;
 M: hello foo this>> ;
@@ -34,8 +34,8 @@ M: hello bing hello-test ;
 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
 
-[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
+[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
-[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
+[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
 [ H{ } ] [ bee protocol-consult ] unit-test
 
 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test

basis/editors/gvim/backend/backend.factor

@@ -1,4 +0,0 @@
-USING: io.backend ;
-IN: editors.gvim.backend
-
-HOOK: gvim-path io-backend ( -- path )

basis/editors/gvim/backend/tags.txt

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

basis/editors/gvim/gvim.factor

@@ -1,10 +1,12 @@
 USING: io.backend io.files kernel math math.parser
 namespaces sequences system combinators
-editors.vim editors.gvim.backend vocabs.loader ;
+editors.vim vocabs.loader ;
 IN: editors.gvim
 
 SINGLETON: gvim
 
+HOOK: gvim-path io-backend ( -- path )
+
 M: gvim vim-command ( file line -- string )
     [ gvim-path , swap , "+" swap number>string append , ] { } make ;
 

basis/editors/gvim/unix/unix.factor

@@ -1,4 +1,4 @@
-USING: io.unix.backend kernel namespaces editors.gvim.backend
+USING: io.unix.backend kernel namespaces editors.gvim
 system ;
 IN: editors.gvim.unix
 

basis/editors/gvim/windows/windows.factor

@@ -1,4 +1,4 @@
-USING: editors.gvim.backend io.files io.windows kernel namespaces
+USING: editors.gvim io.files io.windows kernel namespaces
 sequences windows.shell32 io.paths system ;
 IN: editors.gvim.windows
 

basis/float-vectors/float-vectors-tests.factor

@@ -1,10 +1,10 @@
+USING: tools.test float-vectors vectors sequences kernel math ;
 IN: float-vectors.tests
-USING: tools.test float-vectors vectors sequences kernel ;
 
 [ 0 ] [ 123 <float-vector> length ] unit-test
 
 : do-it
-    12345 [ over push ] each ;
+    12345 [ >float over push ] each ;
 
 [ t ] [
     3 <float-vector> do-it

basis/help/definitions/definitions-tests.factor

@@ -1,6 +1,6 @@
 USING: math definitions help.topics help tools.test
 prettyprint parser io.streams.string kernel source-files
-assocs namespaces words io sequences eval ;
+assocs namespaces words io sequences eval accessors ;
 IN: help.definitions.tests
 
 [ ] [ \ + >link see ] unit-test
@@ -10,7 +10,7 @@ IN: help.definitions.tests
         "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions first assoc-size
+        "foo" source-file definitions>> first assoc-size
     ] unit-test
 
     [ t ] [ "hello" articles get key? ] unit-test
@@ -23,7 +23,7 @@ IN: help.definitions.tests
         "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
         parse-stream drop
 
-        "foo" source-file source-file-definitions first assoc-size
+        "foo" source-file definitions>> first assoc-size
     ] unit-test
 
     [ t ] [ "hello" articles get key? ] unit-test

basis/help/help-docs.factor

@@ -399,5 +399,5 @@ HELP: ABOUT:
 { $description "Defines the main documentation article for the current vocabulary." } ;
 
 HELP: vocab-help
-{ $values { "vocab" "a vocabulary specifier" } { "help" "a help article" } }
+{ $values { "vocab-spec" "a vocabulary specifier" } { "help" "a help article" } }
 { $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT:  } "." } ;

basis/help/lint/lint.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences parser kernel help help.markup
+USING: fry accessors sequences parser kernel help help.markup
 help.topics words strings classes tools.vocabs namespaces io
 io.streams.string prettyprint definitions arrays vectors
 combinators combinators.short-circuit splitting debugger
@@ -39,7 +39,7 @@ IN: help.lint
         $predicate
         $class-description
         $error-description
-    } swap [ elements f like ] curry contains? ;
+    } swap '[ , elements empty? not ] contains? ;
 
 : check-values ( word element -- )
     {
@@ -108,12 +108,10 @@ M: help-error error.
     articles get keys
     vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
     H{ } clone [
-        [
+        '[
-            [ dup >link where dup ] 2dip
+            dup >link where dup
-            [ >r >r first r> at r> push-at ] 2curry
+            [ first , at , push-at ] [ 2drop ] if
-            [ 2drop ]
+        ] each
-            if
-        ] 2curry each
     ] keep ;
 
 : check-about ( vocab -- )

basis/help/markup/markup-tests.factor

@@ -1,13 +1,13 @@
 USING: definitions help help.markup kernel sequences tools.test
-words parser namespaces assocs generic io.streams.string ;
+words parser namespaces assocs generic io.streams.string accessors ;
 IN: help.markup.tests
 
 TUPLE: blahblah quux ;
 
 [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
 
-[ ] [ \ blahblah-quux help ] unit-test
+[ ] [ \ quux>> help ] unit-test
-[ ] [ \ set-blahblah-quux help ] unit-test
+[ ] [ \ >>quux help ] unit-test
 [ ] [ \ blahblah? help ] unit-test
 
 : fooey "fooey" throw ;

basis/help/syntax/syntax-tests.factor

@@ -1,5 +1,6 @@
+USING: kernel tools.test parser vocabs help.syntax namespaces
+eval accessors ;
 IN: help.syntax.tests
-USING: tools.test parser vocabs help.syntax namespaces eval ;
 
 [
     [ "foobar" ] [
@@ -12,5 +13,5 @@ USING: tools.test parser vocabs help.syntax namespaces eval ;
         "help.syntax.tests" vocab vocab-help
     ] unit-test
     
-    [ ] [ f "help.syntax.tests" vocab set-vocab-help ] unit-test
+    [ ] [ "help.syntax.tests" vocab f >>help drop ] unit-test
 ] with-file-vocabs

basis/help/topics/topics-docs.factor

@@ -1,5 +1,6 @@
-USING: help.markup help.syntax help.topics help.crossref help io
+USING: help.markup help.syntax help.crossref help io io.styles
-io.styles hashtables ;
+hashtables strings ;
+IN: help.topics
 
 HELP: articles
 { $var-description "Hashtable mapping article names to " { $link article } " instances." } ;
@@ -14,11 +15,11 @@ HELP: article
 { $description "Outputs a named " { $link article } " object." } ;
 
 HELP: article-title
-{ $values { "article" "an article name or a word" } { "title" "a string" } }
+{ $values { "topic" "an article name or a word" } { "string" string } }
 { $description "Outputs the title of a specific help article." } ;
 
 HELP: article-content
-{ $values { "article" "an article name or a word" } { "content" "a markup element" } }
+{ $values { "topic" "an article name or a word" } { "content" "a markup element" } }
 { $description "Outputs the content of a specific help article." } ;
 
 HELP: all-articles

basis/help/topics/topics-tests.factor

@@ -1,6 +1,6 @@
-USING: definitions help help.topics help.crossref help.markup
+USING: accessors definitions help help.topics help.crossref
-help.syntax kernel sequences tools.test words parser namespaces
+help.markup help.syntax kernel sequences tools.test words parser
-assocs source-files eval ;
+namespaces assocs source-files eval ;
 IN: help.topics.tests
 
 \ article-name must-infer
@@ -16,7 +16,7 @@ IN: help.topics.tests
 
 SYMBOL: foo
 
-[ ] [ { "test" "a" } "Test A" { { $subsection foo } } <article> add-article ] unit-test
+[ ] [ "Test A" { { $subsection foo } } <article> { "test" "a" } add-article ] unit-test
 
 ! Test article location recording
 

basis/hints/hints-docs.factor

@@ -12,7 +12,6 @@ $nl
 $nl
 "Type hints are declared with a parsing word:"
 { $subsection POSTPONE: HINTS: }
-$nl
 "The specialized version of a word which will be compiled by the compiler can be inspected:"
 { $subsection specialized-def } ;
 

basis/io/buffers/buffers-tests.factor

@@ -4,7 +4,7 @@ sequences tools.test namespaces byte-arrays strings accessors
 destructors ;
 
 : buffer-set ( string buffer -- )
-    over >byte-array over buffer-ptr byte-array>memory
+    over >byte-array over ptr>> byte-array>memory
     >r length r> buffer-reset ;
 
 : string>buffer ( string -- buffer )

basis/io/encodings/ascii/ascii-docs.factor

@@ -2,5 +2,10 @@ USING: help.markup help.syntax ;
 IN: io.encodings.ascii
 
 HELP: ascii
-{ $class-description "This is the encoding descriptor which denotes an ASCII encoding. By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." }
+{ $class-description "ASCII encoding descriptor." } ;
-{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "ascii" "ASCII encoding"
+"By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown."
+{ $subsection ascii } ;
+
+ABOUT: "ascii"

basis/io/encodings/utf16/utf16-docs.factor

@@ -1,7 +1,7 @@
 USING: help.markup help.syntax io.encodings strings ;
 IN: io.encodings.utf16
 
-ARTICLE: "io.encodings.utf16" "UTF-16"
+ARTICLE: "io.encodings.utf16" "UTF-16 encoding"
 "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
 { $subsection utf16 }
 { $subsection utf16le }

basis/io/servers/connection/connection-tests.factor

@@ -13,7 +13,7 @@ concurrency.promises io.encodings.ascii io threads calendar ;
 ] unit-test
 
 [ t ] [
-    T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
+    T{ inet4 f "1.2.3.4" 1234 } T{ inet4 f "1.2.3.5" 1235 }
     [ log-connection ] 2keep
     [ remote-address get = ] [ local-address get = ] bi*
     and

basis/io/sockets/sockets.factor

@@ -72,8 +72,8 @@ M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
 M: inet4 make-sockaddr ( inet -- sockaddr )
     "sockaddr-in" <c-object>
     AF_INET over set-sockaddr-in-family
-    over inet4-port htons over set-sockaddr-in-port
+    over port>> htons over set-sockaddr-in-port
-    over inet4-host
+    over host>>
     "0.0.0.0" or
     rot inet-pton *uint over set-sockaddr-in-addr ;
 
@@ -134,8 +134,8 @@ M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
 M: inet6 make-sockaddr ( inet -- sockaddr )
     "sockaddr-in6" <c-object>
     AF_INET6 over set-sockaddr-in6-family
-    over inet6-port htons over set-sockaddr-in6-port
+    over port>> htons over set-sockaddr-in6-port
-    over inet6-host "::" or
+    over host>> "::" or
     rot inet-pton over set-sockaddr-in6-addr ;
 
 M: inet6 parse-sockaddr

basis/io/windows/launcher/launcher.factor

@@ -6,7 +6,7 @@ windows.types math windows.kernel32
 namespaces io.launcher kernel sequences windows.errors
 splitting system threads init strings combinators
 io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors classes.tuple.lib ;
+io.files.private windows destructors ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args
@@ -30,7 +30,19 @@ TUPLE: CreateProcess-args
     0 >>dwCreateFlags ;
 
 : call-CreateProcess ( CreateProcess-args -- )
-    CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
+    {
+        [ lpApplicationName>> ]
+        [ lpCommandLine>> ]
+        [ lpProcessAttributes>> ]
+        [ lpThreadAttributes>> ]
+        [ bInheritHandles>> ]
+        [ dwCreateFlags>> ]
+        [ lpEnvironment>> ]
+        [ lpCurrentDirectory>> ]
+        [ lpStartupInfo>> ]
+        [ lpProcessInformation>> ]
+    } cleave
+    CreateProcess win32-error=0/f ;
 
 : count-trailing-backslashes ( str n -- str n )
     >r "\\" ?tail r> swap [
@@ -139,13 +151,13 @@ M: windows kill-process* ( handle -- )
     swap win32-error=0/f ;
 
 : process-exited ( process -- )
-    dup process-handle exit-code
+    dup handle>> exit-code
-    over process-handle dispose-process
+    over handle>> dispose-process
     notify-exit ;
 
 M: windows wait-for-processes ( -- ? )
     processes get keys dup
-    [ process-handle PROCESS_INFORMATION-hProcess ] map
+    [ handle>> PROCESS_INFORMATION-hProcess ] map
     dup length swap >c-void*-array 0 0
     WaitForMultipleObjects
     dup HEX: ffffffff = [ win32-error ] when

basis/io/windows/nt/backend/backend.factor

@@ -1,9 +1,8 @@
 USING: alien alien.c-types arrays assocs combinators
 continuations destructors io io.backend io.ports io.timeouts
 io.windows io.windows.files libc kernel math namespaces
-sequences threads classes.tuple.lib windows windows.errors
+sequences threads windows windows.errors windows.kernel32
-windows.kernel32 strings splitting io.files
+strings splitting io.files io.buffers qualified ascii system
-io.buffers qualified ascii system
 accessors locals ;
 QUALIFIED: windows.winsock
 IN: io.windows.nt.backend

basis/io/windows/nt/sockets/sockets.factor

@@ -1,9 +1,8 @@
 USING: alien alien.accessors alien.c-types byte-arrays
 continuations destructors io.ports io.timeouts io.sockets
 io.sockets io namespaces io.streams.duplex io.windows
-io.windows.sockets
+io.windows.sockets io.windows.nt.backend windows.winsock kernel
-io.windows.nt.backend windows.winsock kernel libc math sequences
+libc math sequences threads system combinators accessors ;
-threads classes.tuple.lib system combinators accessors ;
 IN: io.windows.nt.sockets
 
 : malloc-int ( object -- object )
@@ -28,71 +27,89 @@ M: winnt WSASocket-flags ( -- DWORD )
     ] keep *void* ;
 
 TUPLE: ConnectEx-args port
-    s* name* namelen* lpSendBuffer* dwSendDataLength*
+    s name namelen lpSendBuffer dwSendDataLength
-    lpdwBytesSent* lpOverlapped* ptr* ;
+    lpdwBytesSent lpOverlapped ptr ;
 
 : wait-for-socket ( args -- n )
-    [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
+    [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
 
 : <ConnectEx-args> ( sockaddr size -- ConnectEx )
     ConnectEx-args new
-        swap >>namelen*
+        swap >>namelen
-        swap >>name*
+        swap >>name
-        f >>lpSendBuffer*
+        f >>lpSendBuffer
-        0 >>dwSendDataLength*
+        0 >>dwSendDataLength
-        f >>lpdwBytesSent*
+        f >>lpdwBytesSent
-        (make-overlapped) >>lpOverlapped* ;
+        (make-overlapped) >>lpOverlapped ; inline
 
 : call-ConnectEx ( ConnectEx -- )
-    ConnectEx-args >tuple*<
+    {
+        [ s>> ]
+        [ name>> ]
+        [ namelen>> ]
+        [ lpSendBuffer>> ]
+        [ dwSendDataLength>> ]
+        [ lpdwBytesSent>> ]
+        [ lpOverlapped>> ]
+        [ ptr>> ]
+    } cleave
     "int"
     { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
     "stdcall" alien-indirect drop
-    winsock-error-string [ throw ] when* ;
+    winsock-error-string [ throw ] when* ; inline
 
 M: object establish-connection ( client-out remote -- )
     make-sockaddr/size <ConnectEx-args>
         swap >>port
-        dup port>> handle>> handle>> >>s*
+        dup port>> handle>> handle>> >>s
-        dup s*>> get-ConnectEx-ptr >>ptr*
+        dup s>> get-ConnectEx-ptr >>ptr
         dup call-ConnectEx
         wait-for-socket drop ;
 
 TUPLE: AcceptEx-args port
-    sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
+    sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
-    dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
+    dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
 
 : init-accept-buffer ( addr AcceptEx -- )
     swap sockaddr-type heap-size 16 +
-        [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
+        [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
-        dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
+        dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
-        drop ;
+        drop ; inline
 
 : <AcceptEx-args> ( server addr -- AcceptEx )
     AcceptEx-args new
         2dup init-accept-buffer
-        swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
+        swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
-        over handle>> handle>> >>sListenSocket*
+        over handle>> handle>> >>sListenSocket
         swap >>port
-        0 >>dwReceiveDataLength*
+        0 >>dwReceiveDataLength
-        f >>lpdwBytesReceived*
+        f >>lpdwBytesReceived
-        (make-overlapped) >>lpOverlapped* ;
+        (make-overlapped) >>lpOverlapped ; inline
 
 : call-AcceptEx ( AcceptEx -- )
-    AcceptEx-args >tuple*< AcceptEx drop
+    {
-    winsock-error-string [ throw ] when* ;
+        [ sListenSocket>> ]
+        [ sAcceptSocket>> ]
+        [ lpOutputBuffer>> ]
+        [ dwReceiveDataLength>> ]
+        [ dwLocalAddressLength>> ]
+        [ dwRemoteAddressLength>> ]
+        [ lpdwBytesReceived>> ]
+        [ lpOverlapped>> ]
+    } cleave AcceptEx drop
+    winsock-error-string [ throw ] when* ; inline
 
 : extract-remote-address ( AcceptEx -- sockaddr )
     {
-        [ lpOutputBuffer*>> ]
+        [ lpOutputBuffer>> ]
-        [ dwReceiveDataLength*>> ]
+        [ dwReceiveDataLength>> ]
-        [ dwLocalAddressLength*>> ]
+        [ dwLocalAddressLength>> ]
-        [ dwRemoteAddressLength*>> ]
+        [ dwRemoteAddressLength>> ]
     } cleave
     f <void*>
     0 <int>
     f <void*>
-    [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+    [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
 
 M: object (accept) ( server addr -- handle sockaddr )
     [
@@ -100,39 +117,49 @@ M: object (accept) ( server addr -- handle sockaddr )
         {
             [ call-AcceptEx ]
             [ wait-for-socket drop ]
-            [ sAcceptSocket*>> <win32-socket> ]
+            [ sAcceptSocket>> <win32-socket> ]
             [ extract-remote-address ]
         } cleave
     ] with-destructors ;
 
 TUPLE: WSARecvFrom-args port
-       s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
+       s lpBuffers dwBufferCount lpNumberOfBytesRecvd
-       lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
+       lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
 
 : make-receive-buffer ( -- WSABUF )
     "WSABUF" malloc-object &free
     default-buffer-size get over set-WSABUF-len
-    default-buffer-size get malloc &free over set-WSABUF-buf ;
+    default-buffer-size get malloc &free over set-WSABUF-buf ; inline
 
 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
     WSARecvFrom-args new
         swap >>port
-        dup port>> handle>> handle>> >>s*
+        dup port>> handle>> handle>> >>s
         dup port>> addr>> sockaddr-type heap-size
-            [ malloc &free >>lpFrom* ]
+            [ malloc &free >>lpFrom ]
-            [ malloc-int &free >>lpFromLen* ] bi
+            [ malloc-int &free >>lpFromLen ] bi
-        make-receive-buffer >>lpBuffers*
+        make-receive-buffer >>lpBuffers
-        1 >>dwBufferCount*
+        1 >>dwBufferCount
-        0 malloc-int &free >>lpFlags*
+        0 malloc-int &free >>lpFlags
-        0 malloc-int &free >>lpNumberOfBytesRecvd*
+        0 malloc-int &free >>lpNumberOfBytesRecvd
-        (make-overlapped) >>lpOverlapped* ;
+        (make-overlapped) >>lpOverlapped ; inline
 
 : call-WSARecvFrom ( WSARecvFrom -- )
-    WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
+    {
+        [ s>> ]
+        [ lpBuffers>> ]
+        [ dwBufferCount>> ]
+        [ lpNumberOfBytesRecvd>> ]
+        [ lpFlags>> ]
+        [ lpFrom>> ]
+        [ lpFromLen>> ]
+        [ lpOverlapped>> ]
+        [ lpCompletionRoutine>> ]
+    } cleave WSARecvFrom socket-error* ; inline
 
 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
-    [ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
+    [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
-    [ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
+    [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
 
 M: winnt (receive) ( datagram -- packet addrspec )
     [
@@ -144,31 +171,41 @@ M: winnt (receive) ( datagram -- packet addrspec )
     ] with-destructors ;
 
 TUPLE: WSASendTo-args port
-       s* lpBuffers* dwBufferCount* lpNumberOfBytesSent*
+       s lpBuffers dwBufferCount lpNumberOfBytesSent
-       dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
+       dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
 
 : make-send-buffer ( packet -- WSABUF )
     "WSABUF" malloc-object &free
     [ >r malloc-byte-array &free r> set-WSABUF-buf ]
     [ >r length r> set-WSABUF-len ]
     [ nip ]
-    2tri ;
+    2tri ; inline
 
 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
     WSASendTo-args new
         swap >>port
-        dup port>> handle>> handle>> >>s*
+        dup port>> handle>> handle>> >>s
         swap make-sockaddr/size
             >r malloc-byte-array &free
-            r> [ >>lpTo* ] [ >>iToLen* ] bi*
+            r> [ >>lpTo ] [ >>iToLen ] bi*
-        swap make-send-buffer >>lpBuffers*
+        swap make-send-buffer >>lpBuffers
-        1 >>dwBufferCount*
+        1 >>dwBufferCount
-        0 >>dwFlags*
+        0 >>dwFlags
-        0 <uint> >>lpNumberOfBytesSent*
+        0 <uint> >>lpNumberOfBytesSent
-        (make-overlapped) >>lpOverlapped* ;
+        (make-overlapped) >>lpOverlapped ; inline
 
 : call-WSASendTo ( WSASendTo -- )
-    WSASendTo-args >tuple*< WSASendTo socket-error* ;
+    {
+        [ s>> ]
+        [ lpBuffers>> ]
+        [ dwBufferCount>> ]
+        [ lpNumberOfBytesSent>> ]
+        [ dwFlags>> ]
+        [ lpTo>> ]
+        [ iToLen>> ]
+        [ lpOverlapped>> ]
+        [ lpCompletionRoutine>> ]
+    } cleave WSASendTo socket-error* ; inline
 
 M: winnt (send) ( packet addrspec datagram -- )
     [

basis/macros/expander/expander.factor

@@ -32,8 +32,8 @@ M: wrapper expand-macros* wrapped>> literal ;
     stack get pop >quotation end (expand-macros) ;
 
 : expand-macro? ( word -- quot ? )
-    dup [ "macro" word-prop ] [ +transform-quot+ word-prop ] bi or dup [
+    dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [
-        swap [ stack-effect in>> length ] [ +transform-n+ word-prop ] bi or
+        swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or
         stack get length <=
     ] [ 2drop f f ] if ;
 

basis/math/complex/complex-docs.factor

@@ -2,18 +2,24 @@ USING: help.markup help.syntax math math.private math.functions
 math.complex.private ;
 IN: math.complex
 
+ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers"
+"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:"
+{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" }
+"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:"
+{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" }
+"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ;
+
 ARTICLE: "complex-numbers" "Complex numbers"
 { $subsection complex }
 "Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "syntax-complex-numbers" } "."
 $nl
-"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero."
-$nl
 "Complex numbers can be taken apart:"
 { $subsection real-part }
 { $subsection imaginary-part }
 { $subsection >rect }
 "Complex numbers can be constructed from real numbers:"
 { $subsection rect> }
+{ $subsection "complex-numbers-zero" }
 { $see-also "syntax-complex-numbers" } ;
 HELP: complex
 { $class-description "The class of complex numbers with non-zero imaginary part." } ;

basis/math/complex/complex-tests.factor

@@ -6,8 +6,13 @@ IN: math.complex.tests
 [ C{ 0 1 } 1 rect> ] must-fail
 
 [ f ] [ C{ 5 12.5 } 5 = ] unit-test
-[ t ] [ C{ 1.0 2.0 } C{ 1 2 }  = ] unit-test
+[ f ] [ C{ 5 12.5 } 5 number= ] unit-test
+
+[ f ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test
+[ t ] [ C{ 1.0 2.0 } C{ 1 2 } number= ] unit-test
+
 [ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test
+[ f ] [ C{ 1.0 2.3 } C{ 1 2 } number= ] unit-test
 
 [ C{ 2 5 } ] [ 2 5  rect> ] unit-test
 [ 2 5 ] [ C{ 2 5 }  >rect ] unit-test
@@ -30,7 +35,7 @@ IN: math.complex.tests
 
 [ C{ 0 1 } ] [ C{ 0 1 } 1  * ] unit-test
 [ C{ 0 1 } ] [ 1 C{ 0 1 }  * ] unit-test
-[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 }  * ] unit-test
+[ C{ 0.0 1.0 } ] [ 1.0 C{ 0 1 }  * ] unit-test
 [ -1 ] [ C{ 0 1 } C{ 0 1 }  * ] unit-test
 [ C{ 0 1 } ] [ 1 C{ 0 1 }  * ] unit-test
 [ C{ 0 1 } ] [ C{ 0 1 } 1  * ] unit-test
@@ -45,18 +50,18 @@ IN: math.complex.tests
 
 [ C{ -3 4 } ] [ C{ 3 -4 }  neg ] unit-test
 
-[ 5 ] [ C{ 3 4 } abs ] unit-test
+[ 5.0 ] [ C{ 3 4 } abs ] unit-test
-[ 5 ] [ -5.0 abs ] unit-test
+[ 5.0 ] [ -5.0 abs ] unit-test
 
 ! Make sure arguments are sane
-[ 0 ] [ 0 arg ] unit-test
+[ 0.0 ] [ 0 arg ] unit-test
-[ 0 ] [ 1 arg ] unit-test
+[ 0.0 ] [ 1 arg ] unit-test
 [ t ] [ -1 arg 3.14 3.15 between? ] unit-test
 [ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test
 [ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test
 
-[ 1 0 ] [ 1 >polar ] unit-test
+[ 1.0 0.0 ] [ 1 >polar ] unit-test
-[ 1 ] [ -1 >polar drop ] unit-test
+[ 1.0 ] [ -1 >polar drop ] unit-test
 [ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
 
 ! I broke something

basis/math/complex/complex.factor

@@ -17,6 +17,14 @@ M: complex absq >rect [ sq ] bi@ + ;
     [ [ real-part ] bi@ ] 2keep
     [ imaginary-part ] bi@ ; inline
 
+M: complex hashcode*
+    nip >rect [ hashcode ] bi@ bitxor ;
+
+M: complex equal?
+    over complex? [
+        2>rect = [ = ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
 M: complex number=
     2>rect number= [ number= ] [ 2drop f ] if ;
 
@@ -36,8 +44,6 @@ M: complex abs absq >float fsqrt ;
 
 M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
 
-M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ;
-
 IN: syntax
 
 : C{ \ } [ first2 rect> ] parse-literal ; parsing

basis/math/functions/functions-docs.factor

@@ -106,7 +106,7 @@ HELP: (rect>)
 
 HELP: rect>
 { $values { "x" real } { "y" real } { "z" number } }
-{ $description "Creates a complex number from real and imaginary components." } ;
+{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ;
 
 HELP: >rect
 { $values { "z" number } { "x" real } { "y" real } }

basis/math/functions/functions-tests.factor

@@ -12,10 +12,11 @@ IN: math.functions.tests
 [ 0.25 ] [ 2.0 -2.0 fpow ] unit-test
 
 [ 4.0 ] [ 16 sqrt ] unit-test
-[ C{ 0 4.0 } ] [ -16 sqrt ] unit-test
+[ 2.0 ] [ 4.0 0.5 ^ ] unit-test
+[ C{ 0.0 4.0 } ] [ -16 sqrt ] unit-test
 
-[ 4.0 ] [ 2 2 ^ ] unit-test
+[ 4 ] [ 2 2 ^ ] unit-test
-[ 0.25 ] [ 2 -2 ^ ] unit-test
+[ 1/4 ] [ 2 -2 ^ ] unit-test
 [ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test
 [ t ] [ e pi i* ^ real-part -1.0 = ] unit-test
 [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
@@ -27,6 +28,8 @@ IN: math.functions.tests
 [ 0 ] [ 0 3.0 ^ ] unit-test
 [ 0 ] [ 0 3 ^ ] unit-test
 
+[ 0.0 ] [ 1 log ] unit-test
+
 [ 1.0 ] [ 0 cosh ] unit-test
 [ 0.0 ] [ 1 acosh ] unit-test