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

basis/alarms/alarms-docs.factor

@@ -9,13 +9,19 @@ HELP: add-alarm
 { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
 
 HELP: later
-{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
+{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
 { $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
 
 HELP: cancel-alarm
 { $values { "alarm" alarm } }
 { $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
 
+HELP: every
+{ $values
+     { "quot" quotation } { "duration" duration }
+     { "alarm" alarm } }
+{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
+
 ARTICLE: "alarms" "Alarms"
 "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
 { $subsection alarm }

basis/alarms/alarms.factor

@@ -82,10 +82,10 @@ PRIVATE>
 : add-alarm ( quot time frequency -- alarm )
     <alarm> [ register-alarm ] keep ;
 
-: later ( quot dt -- alarm )
+: later ( quot duration -- alarm )
     hence f add-alarm ;
 
-: every ( quot dt -- alarm )
+: every ( quot duration -- alarm )
     [ hence ] keep add-alarm ;
 
 : cancel-alarm ( alarm -- )

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/bit-arrays/bit-arrays.factor

@@ -91,5 +91,5 @@ M: bit-array byte-length length 7 + -3 shift ;
 INSTANCE: bit-array sequence
 
 M: bit-array pprint-delims drop \ ?{ \ } ;
-
 M: bit-array >pprint-sequence ;
+M: bit-array pprint* pprint-object ;

basis/bit-vectors/bit-vectors.factor

@@ -34,5 +34,5 @@ INSTANCE: bit-vector growable
 : ?V{ \ } [ >bit-vector ] parse-literal ; parsing
 
 M: bit-vector >pprint-sequence ;
-
 M: bit-vector pprint-delims drop \ ?V{ \ } ;
+M: bit-vector pprint* pprint-object ;

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 ;
+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. Compare two timestamps with the " { $link <=> } " word." } ;
+{ $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 } ". Compare two timestamps with the " { $link <=> } " word." } ;
+{ $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
 
@@ -21,8 +21,8 @@ HELP: <date>
 { $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
 { $examples
     { $example "USING: calendar prettyprint ;"
-               "12 25 2010 <date> ."
+               "2010 12 25 <date> ."
-                "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }"
+               "T{ timestamp\n    { year 2010 }\n    { month 12 }\n    { day 25 }\n    { gmt-offset T{ duration { hour -5 } } }\n}"
     }
 } ;
 
@@ -135,43 +135,37 @@ HELP: instant
 
 HELP: years
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of years." } ;
-{ year years } related-words
 
 HELP: months
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of months." } ;
-{ month months } related-words
 
 HELP: days
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of days." } ;
-{ day days } related-words
 
 HELP: weeks
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of weeks." } ;
-{ week weeks } related-words
 
 HELP: hours
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of hours." } ;
-{ hour hours } related-words
 
 HELP: minutes
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of minutes." } ;
-{ minute minutes } related-words
 
 HELP: seconds
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of seconds." } ;
-{ second seconds } related-words
 
 HELP: milliseconds
 { $values { "x" number } { "duration" duration } }
-{ $description } ;
+{ $description "Creates a duration object with the specified number of milliseconds." } ;
-{ millisecond milliseconds } related-words
+
+{ years months days hours minutes seconds milliseconds } related-words
 
 HELP: leap-year?
 { $values { "obj" object } { "?" "a boolean" } }
@@ -192,7 +186,7 @@ HELP: time+
 { $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 year <=> ."
+               "10 months 2 months time+ 1 years <=> ."
                "+eq+"
     }
     { $example "USING: accessors calendar math.order prettyprint ;"
@@ -201,3 +195,412 @@ HELP: time+
     }
 } ;
 
+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 alias ;
+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,7 +120,7 @@ PRIVATE>
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
-MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
+: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
 : years ( x -- duration ) instant clone swap >>year ;
 : months ( x -- duration ) instant clone swap >>month ;
 : days ( x -- duration ) instant clone swap >>day ;
@@ -125,14 +129,6 @@ MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
 : minutes ( x -- duration ) instant clone swap >>minute ;
 : seconds ( x -- duration ) instant clone swap >>second ;
 : milliseconds ( x -- duration ) 1000 / seconds ;
-ALIAS: year years
-ALIAS: month months
-ALIAS: day days
-ALIAS: week weeks
-ALIAS: hour hours
-ALIAS: minute minutes
-ALIAS: second seconds
-ALIAS: millisecond milliseconds
 
 GENERIC: leap-year? ( obj -- ? )
 
@@ -244,7 +240,7 @@ M: duration time+
         2drop <duration>
     ] if ;
 
-: dt>years ( duration -- x )
+: duration>years ( duration -- x )
     #! Uses average month/year length since duration loses calendar
     #! data
     0 swap
@@ -257,16 +253,16 @@ M: duration time+
         [ second>> seconds-per-year / + ]
     } cleave ;
 
-M: duration <=> [ dt>years ] compare ;
+M: duration <=> [ duration>years ] compare ;
 
-: dt>months ( duration -- x ) dt>years months-per-year * ;
+: duration>months ( duration -- x ) duration>years months-per-year * ;
-: dt>days ( duration -- x ) dt>years days-per-year * ;
+: duration>days ( duration -- x ) duration>years days-per-year * ;
-: dt>hours ( duration -- x ) dt>years hours-per-year * ;
+: duration>hours ( duration -- x ) duration>years hours-per-year * ;
-: dt>minutes ( duration -- x ) dt>years minutes-per-year * ;
+: duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
-: dt>seconds ( duration -- x ) dt>years seconds-per-year * ;
+: duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
-: dt>milliseconds ( duration -- 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 ] [
@@ -310,17 +306,17 @@ M: timestamp time-
 M: duration time-
     before time+ ;
 
-MEMO: <zero> ( -- timestamp )
+: <zero> ( -- 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 )
@@ -331,12 +327,9 @@ MEMO: unix-1970 ( -- timestamp )
     unix-1970 millis milliseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
-
 : hence ( duration -- timestamp ) now swap time+ ;
 : ago ( duration -- 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
     #! http://web.textfiles.com/computers/formulas.txt
@@ -371,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
@@ -403,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/channels.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Channels - based on ideas from newsqueak
-USING: kernel sequences sequences.lib threads continuations
+USING: kernel sequences threads continuations
-random math accessors ;
+random math accessors random ;
 IN: channels
 
 TUPLE: channel receivers senders ;

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/checksums/common/common.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2006, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.bitwise strings io.binary namespaces
+grouping ;
+IN: checksums.common
+
+SYMBOL: bytes-read
+
+: calculate-pad-length ( length -- pad-length )
+    dup 56 < 55 119 ? swap - ;
+
+: pad-last-block ( str big-endian? length -- str )
+    [
+        rot %
+        HEX: 80 ,
+        dup HEX: 3f bitand calculate-pad-length 0 <string> %
+        3 shift 8 rot [ >be ] [ >le ] if %
+    ] "" make 64 group ;
+
+: update-old-new ( old new -- )
+    [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline

basis/checksums/common/summary.txt

@@ -0,0 +1 @@
+Some code shared by MD5, SHA1 and SHA2 implementations

basis/checksums/md5/md5.factor

@@ -1,11 +1,14 @@
-! See http://www.faqs.org/rfcs/rfc1321.html
+! Copyright (C) 2006, 2008 Doug Coleman.
-
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel io io.binary io.files io.streams.byte-array math
 math.functions math.parser namespaces splitting grouping strings
-sequences crypto.common byte-arrays locals sequences.private
+sequences byte-arrays locals sequences.private
-io.encodings.binary symbols math.bitfields.lib checksums ;
+io.encodings.binary symbols math.bitwise checksums
+checksums.common ;
 IN: checksums.md5
 
+! See http://www.faqs.org/rfcs/rfc1321.html
+
 <PRIVATE
 
 SYMBOLS: a b c d old-a old-b old-c old-d ;

basis/checksums/sha1/sha1.factor

@@ -1,7 +1,9 @@
-USING: arrays combinators crypto.common kernel io
+! Copyright (C) 2006, 2008 Doug Coleman.
-io.encodings.binary io.files io.streams.byte-array math.vectors
+! See http://factorcode.org/license.txt for BSD license.
-strings sequences namespaces math parser sequences vectors
+USING: arrays combinators kernel io io.encodings.binary io.files
-io.binary hashtables symbols math.bitfields.lib checksums ;
+io.streams.byte-array math.vectors strings sequences namespaces
+math parser sequences assocs grouping vectors io.binary hashtables
+symbols math.bitwise checksums checksums.common ;
 IN: checksums.sha1
 
 ! Implemented according to RFC 3174.
@@ -45,6 +47,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
         { 3 [ bitxor bitxor ] }
     } case ;
 
+: nth-int-be ( string n -- int )
+    4 * dup 4 + rot <slice> be> ; inline
+
 : make-w ( str -- )
     #! compute w, steps a-b of RFC 3174, section 6.1
     16 [ nth-int-be w get push ] with each
@@ -113,8 +118,16 @@ INSTANCE: sha1 checksum
 M: sha1 checksum-stream ( stream -- sha1 )
     drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
 
+: seq>2seq ( seq -- seq1 seq2 )
+    #! { abcdefgh } -> { aceg } { bdfh }
+    2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
+
+: 2seq>seq ( seq1 seq2 -- seq )
+    #! { aceg } { bdfh } -> { abcdefgh }
+    [ zip concat ] keep like ;
+
 : sha1-interleave ( string -- seq )
-    [ zero? ] left-trim
+    [ zero? ] trim-left
     dup length odd? [ rest ] when
     seq>2seq [ sha1 checksum-bytes ] bi@
     2seq>seq ;

basis/checksums/sha2/sha2.factor

@@ -1,6 +1,8 @@
-USING: crypto.common kernel splitting grouping
+! Copyright (C) 2008 Doug Coleman.
-math sequences namespaces io.binary symbols
+! See http://factorcode.org/license.txt for BSD license.
-math.bitfields.lib checksums ;
+USING: kernel splitting grouping math sequences namespaces
+io.binary symbols math.bitwise checksums checksums.common
+sbufs strings ;
 IN: checksums.sha2
 
 <PRIVATE
@@ -81,6 +83,8 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ -11 bitroll-32 ] keep
     -25 bitroll-32 bitxor bitxor ; inline
 
+: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
+
 : T1 ( W n -- T1 )
     [ swap nth ] keep
     K get nth +
@@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
 : seq>byte-array ( n seq -- string )
     [ swap [ >be % ] curry each ] B{ } make ;
 
+: preprocess-plaintext ( string big-endian? -- padded-string )
+    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
+    >r >sbuf r> over [
+        HEX: 80 ,
+        dup length HEX: 3f bitand
+        calculate-pad-length 0 <string> %
+        length 3 shift 8 rot [ >be ] [ >le ] if %
+    ] "" make over push-all ;
+
 : byte-array>sha2 ( byte-array -- string )
     t preprocess-plaintext
     block-size get group [ process-chunk ] each

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/cocoa/windows/windows.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math cocoa cocoa.messages cocoa.classes
-sequences math.bitfields ;
+sequences math.bitwise ;
 IN: cocoa.windows
 
 : NSBorderlessWindowMask     0 ; inline

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/generator/fixup/fixup.factor

@@ -3,7 +3,7 @@
 USING: arrays byte-arrays generic assocs hashtables io.binary
 kernel kernel.private math namespaces sequences words
 quotations strings alien.accessors alien.strings layouts system
-combinators math.bitfields words.private cpu.architecture
+combinators math.bitwise words.private cpu.architecture
 math.order accessors growable ;
 IN: compiler.generator.fixup
 

basis/compiler/generator/registers/registers.factor

@@ -647,7 +647,7 @@ UNION: immediate fixnum POSTPONE: f ;
 
 : phantom-shuffle ( shuffle -- )
     [ in>> length phantom-datastack get phantom-input ] keep
-    shuffle* phantom-datastack get phantom-append ;
+    shuffle phantom-datastack get phantom-append ;
 
 : phantom->r ( n -- )
     phantom-datastack get phantom-input

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/normalization/normalization.factor

@@ -151,7 +151,7 @@ M: #branch normalize*
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
     [
         [ nip ] [
-            dup [ +bottom+ eq? ] left-trim
+            dup [ +bottom+ eq? ] trim-left
             [ [ length ] bi@ - tail* ] keep append
         ] if
     ] 3map ;

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/assembler/backend/backend.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.generator.fixup kernel namespaces sequences
-words math math.bitfields io.binary parser lexer ;
+words math math.bitwise io.binary parser lexer ;
 IN: cpu.ppc.assembler.backend
 
 : insn ( operand opcode -- ) { 26 0 } bitfield , ;

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! 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
+namespaces sequences classes.tuple words strings
-tools.walker accessors combinators.lib ;
+tools.walker accessors 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

@@ -4,8 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io
 kernel math math.parser namespaces prettyprint quotations
 sequences debugger db db.postgresql.lib db.postgresql.ffi
 db.tuples db.types tools.annotations math.ranges
-combinators sequences.lib classes locals words tools.walker
+combinators classes locals words tools.walker
-namespaces.lib accessors random db.queries destructors ;
+nmake accessors random db.queries destructors ;
 USE: tools.walker
 IN: db.postgresql
 
@@ -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

@@ -1,9 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math namespaces sequences random
+USING: accessors kernel math namespaces sequences random strings
-strings math.parser math.intervals combinators
+math.parser math.intervals combinators math.bitwise nmake db
-math.bitfields.lib namespaces.lib db db.tuples db.types
+db.tuples db.types db.sql classes words shuffle arrays ;
-sequences.lib db.sql classes words shuffle arrays ;
 IN: db.queries
 
 GENERIC: where ( specs obj -- )
@@ -43,13 +42,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@ ;
@@ -149,8 +141,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
 : make-query ( tuple query -- tuple' )
     dupd
     {
-        [ group>> [ do-group ] [ drop ] if-seq ]
+        [ group>> [ drop ] [ do-group ] if-empty ]
-        [ order>> [ do-order ] [ drop ] if-seq ]
+        [ order>> [ drop ] [ do-order ] if-empty ]
         [ limit>> [ do-limit ] [ drop ] if* ]
         [ offset>> [ do-offset ] [ drop ] if* ]
     } 2cleave ;

basis/db/sql/sql.factor

@@ -1,6 +1,6 @@
 USING: kernel parser quotations classes.tuple words math.order
-namespaces.lib namespaces sequences arrays combinators
+nmake namespaces sequences arrays combinators
-prettyprint strings math.parser sequences.lib math symbols ;
+prettyprint strings math.parser math symbols ;
 IN: db.sql
 
 SYMBOLS: insert update delete select distinct columns from as

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

@@ -1,13 +1,11 @@
 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays assocs classes compiler db
+USING: alien arrays assocs classes compiler db hashtables
-hashtables io.files kernel math math.parser namespaces
+io.files kernel math math.parser namespaces prettyprint
-prettyprint sequences strings classes.tuple alien.c-types
+sequences strings classes.tuple alien.c-types continuations
-continuations db.sqlite.lib db.sqlite.ffi db.tuples
+db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
-words combinators.lib db.types combinators math.intervals
+math.intervals io nmake accessors vectors math.ranges random
-io namespaces.lib accessors vectors math.ranges random
+math.bitwise db.queries destructors ;
-math.bitfields.lib db.queries destructors ;
-USE: tools.walker
 IN: db.sqlite
 
 TUPLE: sqlite-db < db path ;
@@ -19,7 +17,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 +50,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

@@ -3,8 +3,8 @@
 USING: io.files kernel tools.test db db.tuples classes
 db.types continuations namespaces math math.ranges
 prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitfields.lib
+db.postgresql accessors random math.bitwise
-math.ranges strings sequences.lib urls fry ;
+math.ranges strings urls fry ;
 IN: db.tuples.tests
 
 TUPLE: person the-id the-name the-number the-real
@@ -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/tuples/tuples.factor

@@ -3,7 +3,7 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors sequences.lib combinators.lib ;
+destructors mirrors ;
 IN: db.tuples
 
 : define-persistent ( class table columns -- )
@@ -71,13 +71,14 @@ SINGLETON: retryable
     ] 2map >>bind-params ;
 
 M: retryable execute-statement* ( statement type -- )
-    drop [
+    drop [ retries>> ] [
         [
+            nip
             [ query-results dispose t ]
             [ ]
             [ regenerate-params bind-statement* f ] cleanup
         ] curry
-    ] [ retries>> ] bi retry drop ;
+    ] bi attempt-all drop ;
 
 : resulting-tuple ( class row out-params -- tuple )
     rot class new [
@@ -159,7 +160,8 @@ M: retryable execute-statement* ( statement type -- )
     dup dup class <select-by-slots-statement> do-select ;
 
 : select-tuple ( tuple -- tuple/f )
-    dup dup class \ query new 1 >>limit <query> do-select ?first ;
+    dup dup class \ query new 1 >>limit <query> do-select
+    [ f ] [ first ] if-empty ;
 
 : do-count ( exemplar-tuple statement -- tuples )
     [

basis/db/types/types.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
-sequences continuations sequences.deep sequences.lib
+sequences continuations sequences.deep
 words namespaces slots slots.private classes mirrors
 classes.tuple combinators calendar.format symbols
 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/farkup/farkup-tests.factor

@@ -88,6 +88,8 @@ IN: farkup.tests
 
 [ ] [ "[{}]" convert-farkup drop ] unit-test
 
+[ "<pre>hello\n</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
+
 [
     "<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
 ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test

basis/float-arrays/float-arrays.factor

@@ -61,8 +61,8 @@ INSTANCE: float-array sequence
 : F{ \ } [ >float-array ] parse-literal ; parsing
 
 M: float-array pprint-delims drop \ F{ \ } ;
-
 M: float-array >pprint-sequence ;
+M: float-array pprint* pprint-object ;
 
 USING: hints math.vectors arrays ;