diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index f07a8b9a2d..49480c0fe0 100755 --- a/basis/alarms/alarms-docs.factor +++ b/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 } diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index cbbebde579..7fdeca9ae6 100755 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -82,10 +82,10 @@ PRIVATE> : add-alarm ( quot time frequency -- 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 -- ) diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor new file mode 100644 index 0000000000..5273c2c7ba --- /dev/null +++ b/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* ; + +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 ; + +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 ; + +: ( 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 ; diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 6f83885d9f..62b8510d17 100755 --- a/basis/alien/structs/structs-docs.factor +++ b/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 -kernel words slots assocs namespaces accessors ; - -! 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 ; +alien.syntax sequences io arrays kernel words assocs namespaces +accessors ; +IN: alien.structs 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." diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index e6a363941d..e82d663d08 100755 --- a/basis/alien/structs/structs.factor +++ b/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 -slots.deprecated alien.c-types cpu.architecture ; +math namespaces parser sequences strings words libc +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 ) - - 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 ] 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 ; diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index d6064ba852..11601f7b63 100755 --- a/basis/bit-arrays/bit-arrays.factor +++ b/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 ; diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index 6a7d68beca..404b26829b 100755 --- a/basis/bit-vectors/bit-vectors.factor +++ b/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 ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 97a95f98b8..9c99ed5cdb 100755 --- a/basis/bootstrap/image/image.factor +++ b/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 - "((tombstone))" "((empty))" ? "hashtables.private" lookup - def>> first [ emit-tuple ] cache-object ; + state>> "((tombstone))" "((empty))" ? + "hashtables.private" lookup def>> first + [ emit-tuple ] cache-object ; ! Arrays M: array ' diff --git a/basis/calendar/backend/backend.factor b/basis/calendar/backend/backend.factor deleted file mode 100644 index 56ccf9e6cc..0000000000 --- a/basis/calendar/backend/backend.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: kernel system ; -IN: calendar.backend - -HOOK: gmt-offset os ( -- hours minutes seconds ) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 5ff3ef6cc1..62ff4ad517 100644 --- a/basis/calendar/calendar-docs.factor +++ b/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: { $description "Returns a timestamp object representing the start of the specified day in your current timezone." } { $examples { $example "USING: calendar prettyprint ;" - "12 25 2010 ." - "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }" + "2010 12 25 ." + "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 } ; -{ year years } related-words +{ $description "Creates a duration object with the specified number of years." } ; HELP: months { $values { "x" number } { "duration" duration } } -{ $description } ; -{ month months } related-words +{ $description "Creates a duration object with the specified number of months." } ; HELP: days { $values { "x" number } { "duration" duration } } -{ $description } ; -{ day days } related-words +{ $description "Creates a duration object with the specified number of days." } ; HELP: weeks { $values { "x" number } { "duration" duration } } -{ $description } ; -{ week weeks } related-words +{ $description "Creates a duration object with the specified number of weeks." } ; HELP: hours { $values { "x" number } { "duration" duration } } -{ $description } ; -{ hour hours } related-words +{ $description "Creates a duration object with the specified number of hours." } ; HELP: minutes { $values { "x" number } { "duration" duration } } -{ $description } ; -{ minute minutes } related-words +{ $description "Creates a duration object with the specified number of minutes." } ; HELP: seconds { $values { "x" number } { "duration" duration } } -{ $description } ; -{ second seconds } related-words +{ $description "Creates a duration object with the specified number of seconds." } ; HELP: milliseconds { $values { "x" number } { "duration" duration } } -{ $description } ; -{ millisecond milliseconds } related-words +{ $description "Creates a duration object with the specified number of milliseconds." } ; + +{ years months days hours minutes seconds milliseconds } related-words HELP: leap-year? { $values { "obj" object } { "?" "a boolean" } } @@ -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 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: +{ $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 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 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" diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 7d9716ae1a..995bd23c09 100755 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -33,8 +33,8 @@ IN: calendar.tests [ t ] [ 2006 10 10 0 0 0 instant 10 minutes time+ 2006 10 10 0 10 0 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ - 2006 10 10 0 10 30 instant = ] unit-test +[ +eq+ ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ + 2006 10 10 0 10 30 instant <=> ] unit-test [ t ] [ 2006 10 10 0 0 0 instant 3/4 minutes time+ 2006 10 10 0 0 45 instant = ] unit-test [ t ] [ 2006 10 10 0 0 0 instant -3/4 minutes time+ diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index fd99464bd3..c2c386a790 100755 --- a/basis/calendar/calendar.factor +++ b/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 -accessors combinators locals classes.tuple math.order -memoize summary combinators.short-circuit alias ; +strings system vocabs.loader threads accessors combinators +locals classes.tuple math.order summary +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 ; +: instant ( -- duration ) 0 0 0 0 0 0 ; : 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 ; : 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 ] 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 * ; -: dt>days ( duration -- x ) dt>years days-per-year * ; -: dt>hours ( duration -- x ) dt>years hours-per-year * ; -: dt>minutes ( duration -- x ) dt>years minutes-per-year * ; -: dt>seconds ( duration -- x ) dt>years seconds-per-year * ; -: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ; +: duration>months ( duration -- x ) duration>years months-per-year * ; +: duration>days ( duration -- x ) duration>years days-per-year * ; +: duration>hours ( duration -- x ) duration>years hours-per-year * ; +: duration>minutes ( duration -- x ) duration>years minutes-per-year * ; +: duration>seconds ( duration -- x ) duration>years seconds-per-year * ; +: 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: ( -- timestamp ) -0 0 0 0 0 0 instant ; +: ( -- timestamp ) + 0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) clone instant >>gmt-offset dup time- time+ = ; -MEMO: unix-1970 ( -- timestamp ) +: unix-1970 ( -- timestamp ) 1970 1 1 0 0 0 instant ; -: 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) ; + -: sunday ( timestamp -- timestamp ) 0 day-this-week ; -: monday ( timestamp -- timestamp ) 1 day-this-week ; -: tuesday ( timestamp -- timestamp ) 2 day-this-week ; -: wednesday ( timestamp -- timestamp ) 3 day-this-week ; -: thursday ( timestamp -- timestamp ) 4 day-this-week ; -: friday ( timestamp -- timestamp ) 5 day-this-week ; -: saturday ( timestamp -- timestamp ) 6 day-this-week ; +: sunday ( timestamp -- new-timestamp ) 0 day-this-week ; +: monday ( timestamp -- new-timestamp ) 1 day-this-week ; +: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ; +: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ; +: thursday ( timestamp -- new-timestamp ) 4 day-this-week ; +: friday ( timestamp -- new-timestamp ) 5 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 ; diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 3efe33e265..c433a118c2 100755 --- a/basis/calendar/format/format-tests.factor +++ b/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 diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 6383d4ec42..1da554e0f1 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,5 +1,5 @@ -USING: alien alien.c-types arrays calendar.backend -kernel structs math unix.time namespaces system ; +USING: alien alien.c-types arrays calendar kernel structs +math unix.time namespaces system ; IN: calendar.unix : get-time ( -- alien ) diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index b621d3bde3..508cbb0a49 100755 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,5 +1,5 @@ -USING: calendar.backend namespaces alien.c-types system -windows windows.kernel32 kernel math combinators ; +USING: calendar namespaces alien.c-types system windows +windows.kernel32 kernel math combinators ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 9b5cbee04b..545d8a0e1d 100755 --- a/basis/channels/channels.factor +++ b/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 -random math accessors ; +USING: kernel sequences threads continuations +random math accessors random ; IN: channels TUPLE: channel receivers senders ; diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index c9cfc83d27..9c1878e14d 100755 --- a/basis/channels/remote/remote.factor +++ b/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 remote-channel M: remote-channel to ( value remote-channel -- ) - [ [ \ to , remote-channel-id , , ] { } make ] keep - remote-channel-node "remote-channels" + [ [ \ to , id>> , , ] { } make ] keep + node>> "remote-channels" send-synchronous no-channel = [ no-channel throw ] when ; M: remote-channel from ( remote-channel -- value ) - [ [ \ from , remote-channel-id , ] { } make ] keep - remote-channel-node "remote-channels" + [ [ \ from , id>> , ] { } make ] keep + node>> "remote-channels" send-synchronous dup no-channel = [ no-channel throw ] when* ; [ diff --git a/basis/calendar/backend/authors.txt b/basis/checksums/common/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/calendar/backend/authors.txt rename to basis/checksums/common/authors.txt diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor new file mode 100644 index 0000000000..ea1c6f5b39 --- /dev/null +++ b/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 % + 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 diff --git a/basis/checksums/common/summary.txt b/basis/checksums/common/summary.txt new file mode 100644 index 0000000000..0956c052a4 --- /dev/null +++ b/basis/checksums/common/summary.txt @@ -0,0 +1 @@ +Some code shared by MD5, SHA1 and SHA2 implementations diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index f0e0c71c19..6158254f84 100755 --- a/basis/checksums/md5/md5.factor +++ b/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 -io.encodings.binary symbols math.bitfields.lib checksums ; +sequences byte-arrays locals sequences.private +io.encodings.binary symbols math.bitwise checksums +checksums.common ; IN: checksums.md5 +! See http://www.faqs.org/rfcs/rfc1321.html + 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 ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 6cf7914e6c..ac93c05260 100755 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -1,6 +1,8 @@ -USING: crypto.common kernel splitting grouping -math sequences namespaces io.binary symbols -math.bitfields.lib checksums ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel splitting grouping math sequences namespaces +io.binary symbols math.bitwise checksums checksums.common +sbufs strings ; IN: checksums.sha2 r dup 3 + r> 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 % + 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 diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index 4b56d81626..e1d6672872 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -20,10 +20,10 @@ CLASS: { test-foo -[ 1 ] [ "x" get NSRect-x ] unit-test -[ 2 ] [ "x" get NSRect-y ] unit-test -[ 101 ] [ "x" get NSRect-w ] unit-test -[ 102 ] [ "x" get NSRect-h ] unit-test +[ 1.0 ] [ "x" get NSRect-x ] unit-test +[ 2.0 ] [ "x" get NSRect-y ] unit-test +[ 101.0 ] [ "x" get NSRect-w ] 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 -[ 2 ] [ "x" get NSRect-y ] unit-test -[ 101 ] [ "x" get NSRect-w ] unit-test -[ 102 ] [ "x" get NSRect-h ] unit-test +[ 1.0 ] [ "x" get NSRect-x ] unit-test +[ 2.0 ] [ "x" get NSRect-y ] unit-test +[ 101.0 ] [ "x" get NSRect-w ] unit-test +[ 102.0 ] [ "x" get NSRect-h ] unit-test diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index 74a181f9a2..dd2d1bfd41 100755 --- a/basis/cocoa/windows/windows.factor +++ b/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 diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 418aac6560..1f941a0f88 100755 --- a/basis/compiler/compiler-docs.factor +++ b/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" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index d340c21663..2dd6e440d5 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -43,8 +43,8 @@ SYMBOL: +failed+ [ dup crossref? [ - dependencies get - generic-dependencies get + dependencies get >alist + generic-dependencies get >alist compiled-xref ] [ drop ] if ] tri ; diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index ae30502524..5a3337fb32 100755 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/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 diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index e460f5558b..e909db3f83 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/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 diff --git a/basis/compiler/tree/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor similarity index 95% rename from basis/compiler/tree/intrinsics/intrinsics.factor rename to basis/compiler/intrinsics/intrinsics.factor index 5bcc58626b..b995e6d737 100644 --- a/basis/compiler/tree/intrinsics/intrinsics.factor +++ b/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 ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor old mode 100644 new mode 100755 index 9d2b43c1df..18f7f67787 --- a/basis/compiler/tests/alien.factor +++ b/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" } diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 9f42ad201f..4c39da0479 100755 --- a/basis/compiler/tests/optimizer.factor +++ b/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 diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index 1085feb0c6..c6cbb79ce5 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/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 ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 8072a4229e..bb30cda685 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/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? diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 8056e75b3e..cc5f0619cd 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/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 -compiler.tree.intrinsics +stack-checker.branches +compiler.intrinsics +compiler.tree compiler.tree.combinators compiler.tree.propagation.info compiler.tree.propagation.branches ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor old mode 100644 new mode 100755 index 3ea9139e5f..9ebf064f79 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/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? [ - remove-flushable-call - ] [ - dup some-outputs-dead? [ - dup drop-dead-outputs 2array - ] when - ] if ; + dup dead-flushable-call? + [ remove-flushable-call ] [ maybe-drop-dead-outputs ] 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 ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 0b7db5b36a..f51046c6cb 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/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 diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index d69f6cab9e..0324b31199 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/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 [ [ 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 diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 08734ec095..5aaeed360a 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/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 -compiler.tree compiler.tree.combinators ; +USING: kernel arrays accessors sequences sequences.private words +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>> \ eq? [ + last-literal tuple-layout? + ] [ drop f ] if ; + +MEMO: (tuple-boa-expansion) ( n -- quot ) + [ + [ 2 + ] map + [ '[ [ , 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: -expansion ( n -- quot ) + [ + [ swap (array) ] % + [ \ 2dup , , [ swap set-array-nth ] % ] each + \ nip , + ] [ ] make splice-quot ; + +: expand-? ( #call -- ? ) + dup word>> \ eq? [ + first-literal dup integer? + [ 0 32 between? ] [ drop f ] if + ] [ drop f ] if ; + +: expand- ( #call -- node ) + first-literal -expansion ; + +: bytes>cells ( m -- n ) cell align cell /i ; + +MEMO: -expansion ( n -- quot ) + [ + [ (byte-array) ] % + bytes>cells [ cell * ] map + [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each + ] [ ] make splice-quot ; + +: expand-? ( #call -- ? ) + dup word>> \ eq? [ + first-literal dup integer? + [ 0 128 between? ] [ drop f ] if + ] [ drop f ] if ; + +: expand- ( #call -- nodes ) + first-literal -expansion ; + +M: #call finalize* + { + { [ dup builtin-predicate? ] [ expand-builtin-predicate ] } + { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] } + { [ dup expand-? ] [ expand- ] } + { [ dup expand-? ] [ expand- ] } + [ ] + } cond ; + M: node finalize* ; : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ; diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 12c7a60ec8..08481726dc 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/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 ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index f3ecd7ae65..8f2220aaaf 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/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 ; : ( -- info ) \ value-info new ; +: read-only-slots ( values class -- slots ) + all-slots + [ read-only>> [ drop f ] unless ] 2map + f prefix ; + +DEFER: + +: init-literal-info ( info -- info ) + dup literal>> class >>class + dup literal>> dup real? [ [a,a] >>interval ] [ + [ [-inf,inf] >>interval ] dip + { + { [ dup complex? ] [ + [ real-part ] + [ imaginary-part ] bi + 2array >>slots + ] } + { [ dup tuple? ] [ + [ tuple-slots [ ] map ] [ class ] bi + read-only-slots >>slots + ] } + [ drop ] + } cond + ] if ; inline + : init-value-info ( info -- info ) dup literal?>> [ - dup literal>> class >>class - dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval + init-literal-info ] [ 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 ) @@ -84,7 +106,7 @@ slots ; init-value-info ; foldable : ( class -- info ) - dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or + dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or ; foldable : ( interval -- info ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 09f50b21ea..4f93769b7f 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/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 -classes.union sets quotations assocs combinators words -namespaces +math.partial-dispatch generic generic.standard generic.math +classes.algebra classes.union sets quotations assocs combinators +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 ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 23323e107d..d31de354d1 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/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 @ - ] +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 -] +outputs+ set-word-prop + 2bi and maybe-or-never +] "outputs" set-word-prop { { >fixnum fixnum } @@ -226,7 +227,7 @@ generic-comparison-ops [ interval-intersect ] 2bi - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] assoc-each { @@ -250,36 +251,36 @@ generic-comparison-ops [ } } cond [ fixnum fits? fixnum integer ? ] keep - [ 2nip ] curry +outputs+ set-word-prop + [ 2nip ] curry "outputs" set-word-prop ] each -{ } [ +{ (tuple) } [ [ literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if [ clear ] dip - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] each \ new [ literal>> dup tuple-class? [ drop tuple ] unless -] +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 diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index 358944d1b7..9e4d99e462 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/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 -- ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 503c633077..f04460f32a 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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 ] + [ 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 diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index d664ae5ccf..809a85a51f 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/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 -generic.standard generic.math +math math.private slots generic definitions 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 [ ] 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 ] } @@ -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 ] [ - [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] - [ compute-constraints ] - 2bi - ] if ; + dup word>> { + { [ 2dup foldable-call? ] [ fold-call ] } + { [ 2dup do-inlining ] [ 2drop ] } + [ + [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] + [ compute-constraints ] + 2bi + ] + } cond ; M: #call annotate-node dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ; diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 5e3480be2f..08a8520d0a 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -31,26 +31,19 @@ UNION: fixed-length-sequence array byte-array string ; : tuple-constructor? ( word -- ? ) { } memq? ; -: read-only-slots ( values class -- slots ) - #! Delegation. - all-slots rest-slice - [ read-only>> [ drop f ] unless ] 2map - { f f } prepend ; - : fold- ( values class -- info ) - [ , f , [ literal>> ] map % ] { } make >tuple + [ [ literal>> ] map ] dip prefix >tuple ; : (propagate-tuple-constructor) ( values class -- info ) [ [ value-info ] map ] dip [ read-only-slots ] keep - over 2 tail-slice [ dup [ literal?>> ] when ] all? [ - [ 2 tail-slice ] dip fold- + over rest-slice [ dup [ literal?>> ] when ] all? [ + [ rest-slice ] dip fold- ] [ ] if ; : propagate- ( #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 ] } { [ 2dup length-accessor? ] [ nip length>> ] } diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 334fcb11f0..858e40347f 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/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 ] [ dup 1 slot drop 2 slot drop ] [ 1 cons boa over [ "A" throw ] when car>> ] diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 97b4e2aee2..6fc0e76310 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/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 diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index 4da079e812..5e2f1bb6d1 100755 --- a/basis/concurrency/distributed/distributed.factor +++ b/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 + id>> local-node get-global (serialize) ; : stop-node ( node -- ) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 00bdb4b7c9..0aee836cf1 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/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 ; diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index 072f50520c..b881f5a974 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/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 , ; diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index 6413cf839c..634040b0d0 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/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 -compiler.generator.registers compiler.generator.fixup +hashtables hashtables.private sequences.private sbufs vectors system layouts -math.floats.private classes slots.private combinators -compiler.constants ; +math.floats.private classes slots.private +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 "layout" get size>> 2 + cells %allot -! ! Store layout -! "layout" get 12 load-indirect -! 12 11 cell STW -! ! Store tagged ptr in reg -! "tuple" get tuple %store-tagged -! ] H{ -! { +input+ { { [ ] "layout" } } } -! { +scratch+ { { f "tuple" } } } -! { +output+ { "tuple" } } -! } define-intrinsic -! -! \ (array) [ -! array "n" get 2 + cells %allot -! ! Store length -! "n" operand 12 LI -! 12 11 cell STW -! ! Store tagged ptr in reg -! "array" get object %store-tagged -! ] H{ -! { +input+ { { [ ] "n" } } } -! { +scratch+ { { f "array" } } } -! { +output+ { "array" } } -! } define-intrinsic -! -! \ (byte-array) [ -! byte-array "n" get 2 cells + %allot -! ! Store length -! "n" operand 12 LI -! 12 11 cell STW -! ! Store tagged ptr in reg -! "array" get object %store-tagged -! ] H{ -! { +input+ { { [ ] "n" } } } -! { +scratch+ { { f "array" } } } -! { +output+ { "array" } } -! } define-intrinsic +\ (tuple) [ + tuple "layout" get size>> 2 + cells %allot + ! Store layout + "layout" get 12 load-indirect + 12 11 cell STW + ! Store tagged ptr in reg + "tuple" get tuple %store-tagged +] H{ + { +input+ { { [ ] "layout" } } } + { +scratch+ { { f "tuple" } } } + { +output+ { "tuple" } } +} define-intrinsic + +\ (array) [ + array "n" get 2 + cells %allot + ! Store length + "n" operand 12 LI + 12 11 cell STW + ! Store tagged ptr in reg + "array" get object %store-tagged +] H{ + { +input+ { { [ ] "n" } } } + { +scratch+ { { f "array" } } } + { +output+ { "array" } } +} define-intrinsic + +\ (byte-array) [ + byte-array "n" get 2 cells + %allot + ! Store length + "n" operand 12 LI + 12 11 cell STW + ! Store tagged ptr in reg + "array" get object %store-tagged +] H{ + { +input+ { { [ ] "n" } } } + { +scratch+ { { f "array" } } } + { +output+ { "array" } } +} define-intrinsic \ [ 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 - "value" operand "offset" operand 0 roll call ; inline + "scratch" operand "offset" operand "alien" operand ADD + "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" } } } ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index c1697f1d98..6e864ab968 100755 --- a/basis/cpu/x86/64/64.factor +++ b/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 ) diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor index 536b914f39..a0cfd1b01e 100755 --- a/basis/cpu/x86/intrinsics/intrinsics.factor +++ b/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 -compiler.generator.fixup sequences.private sbufs sbufs.private +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 "layout" get size>> 2 + cells [ -! ! Store layout -! "layout" get "scratch" get load-literal -! 1 object@ "scratch" operand MOV -! ! Store tagged ptr in reg -! "tuple" get tuple %store-tagged -! ] %allot -! ] H{ -! { +input+ { { [ ] "layout" } } } -! { +scratch+ { { f "tuple" } { f "scratch" } } } -! { +output+ { "tuple" } } -! } define-intrinsic -! -! \ (array) [ -! array "n" get 2 + cells [ -! ! Store length -! 1 object@ "n" operand MOV -! ! Store tagged ptr in reg -! "array" get object %store-tagged -! ] %allot -! ] H{ -! { +input+ { { [ ] "n" } } } -! { +scratch+ { { f "array" } } } -! { +output+ { "array" } } -! } define-intrinsic -! -! \ (byte-array) [ -! byte-array "n" get 2 cells + [ -! ! Store length -! 1 object@ "n" operand MOV -! ! Store tagged ptr in reg -! "array" get object %store-tagged -! ] %allot -! ] H{ -! { +input+ { { [ ] "n" } } } -! { +scratch+ { { f "array" } } } -! { +output+ { "array" } } -! } define-intrinsic +\ (tuple) [ + tuple "layout" get size>> 2 + cells [ + ! Store layout + "layout" get "scratch" get load-literal + 1 object@ "scratch" operand MOV + ! Store tagged ptr in reg + "tuple" get tuple %store-tagged + ] %allot +] H{ + { +input+ { { [ ] "layout" } } } + { +scratch+ { { f "tuple" } { f "scratch" } } } + { +output+ { "tuple" } } +} define-intrinsic + +\ (array) [ + array "n" get 2 + cells [ + ! Store length + 1 object@ "n" operand MOV + ! Store tagged ptr in reg + "array" get object %store-tagged + ] %allot +] H{ + { +input+ { { [ ] "n" } } } + { +scratch+ { { f "array" } } } + { +output+ { "array" } } +} define-intrinsic + +\ (byte-array) [ + byte-array "n" get 2 cells + [ + ! Store length + 1 object@ "n" operand MOV + ! Store tagged ptr in reg + "array" get object %store-tagged + ] %allot +] H{ + { +input+ { { [ ] "n" } } } + { +scratch+ { { f "array" } } } + { +output+ { "array" } } +} define-intrinsic \ [ ratio 3 cells [ diff --git a/extra/csv/authors.txt b/basis/csv/authors.txt similarity index 100% rename from extra/csv/authors.txt rename to basis/csv/authors.txt diff --git a/extra/csv/csv-docs.factor b/basis/csv/csv-docs.factor similarity index 100% rename from extra/csv/csv-docs.factor rename to basis/csv/csv-docs.factor diff --git a/extra/csv/csv-tests.factor b/basis/csv/csv-tests.factor similarity index 100% rename from extra/csv/csv-tests.factor rename to basis/csv/csv-tests.factor diff --git a/extra/csv/csv.factor b/basis/csv/csv.factor similarity index 100% rename from extra/csv/csv.factor rename to basis/csv/csv.factor diff --git a/extra/csv/summary.txt b/basis/csv/summary.txt similarity index 100% rename from extra/csv/summary.txt rename to basis/csv/summary.txt diff --git a/basis/editors/gvim/backend/authors.txt b/basis/db/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/editors/gvim/backend/authors.txt rename to basis/db/authors.txt diff --git a/extra/db/db-tests.factor b/basis/db/db-tests.factor similarity index 96% rename from extra/db/db-tests.factor rename to basis/db/db-tests.factor index 0d95e3aea7..3f1dab2c37 100755 --- a/extra/db/db-tests.factor +++ b/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 diff --git a/extra/db/db.factor b/basis/db/db.factor similarity index 85% rename from extra/db/db.factor rename to basis/db/db.factor index c52d1db148..10da653c9f 100755 --- a/extra/db/db.factor +++ b/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 -tools.walker accessors combinators.lib ; +namespaces sequences classes.tuple words strings +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 ) - new-db make-db* ; +: make-db ( seq class -- 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 - dup delete-statements>> dispose-statements - handle>> db-close + { + [ insert-statements>> dispose-statements ] + [ update-statements>> dispose-statements ] + [ 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: db ( str in out -- statement ) -HOOK: db ( str in out -- statement ) +HOOK: db ( string in out -- statement ) +HOOK: db ( string in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( statement -- ) GENERIC: low-level-bind ( statement -- ) diff --git a/extra/db/errors/errors.factor b/basis/db/errors/errors.factor similarity index 99% rename from extra/db/errors/errors.factor rename to basis/db/errors/errors.factor index 1e0d1e7fb4..da6301639f 100644 --- a/extra/db/errors/errors.factor +++ b/basis/db/errors/errors.factor @@ -6,6 +6,5 @@ IN: db.errors ERROR: db-error ; ERROR: sql-error ; - ERROR: table-exists ; ERROR: bad-schema ; diff --git a/extra/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor similarity index 87% rename from extra/db/pools/pools-tests.factor rename to basis/db/pools/pools-tests.factor index 34e072c3a5..f07d1e8468 100644 --- a/extra/db/pools/pools-tests.factor +++ b/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 "pool" set ] unit-test +[ ] [ "pool-test.db" temp-file sqlite-db "pool" set ] unit-test [ ] [ "pool" get expired>> t >>expired drop ] unit-test diff --git a/extra/db/pools/pools.factor b/basis/db/pools/pools.factor similarity index 100% rename from extra/db/pools/pools.factor rename to basis/db/pools/pools.factor diff --git a/basis/units/authors.txt b/basis/db/postgresql/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/units/authors.txt rename to basis/db/postgresql/authors.txt diff --git a/extra/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor similarity index 100% rename from extra/db/postgresql/ffi/ffi.factor rename to basis/db/postgresql/ffi/ffi.factor diff --git a/extra/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor similarity index 100% rename from extra/db/postgresql/lib/lib.factor rename to basis/db/postgresql/lib/lib.factor diff --git a/extra/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor similarity index 100% rename from extra/db/postgresql/postgresql-tests.factor rename to basis/db/postgresql/postgresql-tests.factor diff --git a/extra/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor similarity index 97% rename from extra/db/postgresql/postgresql.factor rename to basis/db/postgresql/postgresql.factor index e57efbc360..d833063b51 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/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 -namespaces.lib accessors random db.queries destructors ; +combinators classes locals words tools.walker +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 diff --git a/extra/db/queries/queries.factor b/basis/db/queries/queries.factor similarity index 91% rename from extra/db/queries/queries.factor rename to basis/db/queries/queries.factor index 3a751a9736..a28f283d30 100644 --- a/extra/db/queries/queries.factor +++ b/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 -strings math.parser math.intervals combinators -math.bitfields.lib namespaces.lib db db.tuples db.types -sequences.lib db.sql classes words shuffle arrays ; +USING: accessors kernel math namespaces sequences random strings +math.parser math.intervals combinators math.bitwise nmake db +db.tuples db.types 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 ( tuple class -- statement ) : make-query ( tuple query -- tuple' ) dupd { - [ group>> [ do-group ] [ drop ] if-seq ] - [ order>> [ do-order ] [ drop ] if-seq ] + [ group>> [ drop ] [ do-group ] if-empty ] + [ order>> [ drop ] [ do-order ] if-empty ] [ limit>> [ do-limit ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; diff --git a/extra/db/sql/sql-tests.factor b/basis/db/sql/sql-tests.factor similarity index 100% rename from extra/db/sql/sql-tests.factor rename to basis/db/sql/sql-tests.factor diff --git a/extra/db/sql/sql.factor b/basis/db/sql/sql.factor similarity index 95% rename from extra/db/sql/sql.factor rename to basis/db/sql/sql.factor index 7dd4abf4be..06428485e1 100755 --- a/extra/db/sql/sql.factor +++ b/basis/db/sql/sql.factor @@ -1,6 +1,6 @@ USING: kernel parser quotations classes.tuple words math.order -namespaces.lib namespaces sequences arrays combinators -prettyprint strings math.parser sequences.lib math symbols ; +nmake namespaces sequences arrays combinators +prettyprint strings math.parser math symbols ; IN: db.sql SYMBOLS: insert update delete select distinct columns from as diff --git a/extra/db/sqlite/authors.txt b/basis/db/sqlite/authors.txt similarity index 100% rename from extra/db/sqlite/authors.txt rename to basis/db/sqlite/authors.txt diff --git a/extra/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor similarity index 98% rename from extra/db/sqlite/ffi/ffi.factor rename to basis/db/sqlite/ffi/ffi.factor index b443f53e78..9f033a1d3c 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/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 ; diff --git a/extra/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor similarity index 100% rename from extra/db/sqlite/lib/lib.factor rename to basis/db/sqlite/lib/lib.factor diff --git a/extra/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor similarity index 99% rename from extra/db/sqlite/sqlite-tests.factor rename to basis/db/sqlite/sqlite-tests.factor index b30cb4ba80..67eac2702b 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/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')" diff --git a/extra/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor similarity index 91% rename from extra/db/sqlite/sqlite.factor rename to basis/db/sqlite/sqlite.factor index 794ff5bacd..dc8104ba00 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/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 -hashtables io.files kernel math math.parser namespaces -prettyprint sequences strings classes.tuple alien.c-types -continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors vectors math.ranges random -math.bitfields.lib db.queries destructors ; -USE: tools.walker +USING: alien arrays assocs classes compiler db hashtables +io.files kernel math math.parser namespaces prettyprint +sequences strings classes.tuple alien.c-types continuations +db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators +math.intervals io nmake accessors vectors math.ranges random +math.bitwise db.queries destructors ; 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 ) diff --git a/extra/db/sqlite/test.txt b/basis/db/sqlite/test.txt similarity index 100% rename from extra/db/sqlite/test.txt rename to basis/db/sqlite/test.txt diff --git a/extra/db/summary.txt b/basis/db/summary.txt similarity index 100% rename from extra/db/summary.txt rename to basis/db/summary.txt diff --git a/extra/db/tags.txt b/basis/db/tags.txt similarity index 100% rename from extra/db/tags.txt rename to basis/db/tags.txt diff --git a/extra/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor similarity index 98% rename from extra/db/tuples/tuples-tests.factor rename to basis/db/tuples/tuples-tests.factor index f5b74b51c8..3b04454995 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/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 -math.ranges strings sequences.lib urls fry ; +db.postgresql accessors random math.bitwise +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 diff --git a/extra/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor similarity index 96% rename from extra/db/tuples/tuples.factor rename to basis/db/tuples/tuples.factor index 1b7ab24366..437224ea5a 100755 --- a/extra/db/tuples/tuples.factor +++ b/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 do-select ; : select-tuple ( tuple -- tuple/f ) - dup dup class \ query new 1 >>limit do-select ?first ; + dup dup class \ query new 1 >>limit do-select + [ f ] [ first ] if-empty ; : do-count ( exemplar-tuple statement -- tuples ) [ diff --git a/extra/db/types/types.factor b/basis/db/types/types.factor similarity index 88% rename from extra/db/types/types.factor rename to basis/db/types/types.factor index c3480093c5..d3b99fcff3 100755 --- a/extra/db/types/types.factor +++ b/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>> ; diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 72463caf26..f8897712e7 100755 --- a/basis/debugger/debugger-docs.factor +++ b/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 -io.files.private listener ; +help generic.standard continuations system io.files.private +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" diff --git a/basis/debugger/threads/threads.factor b/basis/debugger/threads/threads.factor index 093d231d08..7bb240859e 100644 --- a/basis/debugger/threads/threads.factor +++ b/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 ; diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 09a90121bd..d1e7d31656 100755 --- a/basis/delegate/delegate-tests.factor +++ b/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 2 whoa ] unit-test [ 3 ] [ 1 0 f 2 whoa ] unit-test -[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test -[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test +[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] 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 diff --git a/basis/editors/gvim/backend/backend.factor b/basis/editors/gvim/backend/backend.factor deleted file mode 100644 index e2e2f0626e..0000000000 --- a/basis/editors/gvim/backend/backend.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: io.backend ; -IN: editors.gvim.backend - -HOOK: gvim-path io-backend ( -- path ) diff --git a/basis/editors/gvim/backend/tags.txt b/basis/editors/gvim/backend/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/editors/gvim/backend/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor index 041f3db675..4cc9de17a1 100755 --- a/basis/editors/gvim/gvim.factor +++ b/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 ; diff --git a/basis/editors/gvim/unix/unix.factor b/basis/editors/gvim/unix/unix.factor index 3b8f7454c1..82b6bf199d 100644 --- a/basis/editors/gvim/unix/unix.factor +++ b/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 diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor index daf5409c94..8c4e1aaacb 100755 --- a/basis/editors/gvim/windows/windows.factor +++ b/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 diff --git a/extra/farkup/authors.txt b/basis/farkup/authors.txt similarity index 100% rename from extra/farkup/authors.txt rename to basis/farkup/authors.txt diff --git a/extra/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor similarity index 100% rename from extra/farkup/farkup-docs.factor rename to basis/farkup/farkup-docs.factor diff --git a/extra/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor similarity index 98% rename from extra/farkup/farkup-tests.factor rename to basis/farkup/farkup-tests.factor index 005e875d89..0f96934798 100644 --- a/extra/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -88,6 +88,8 @@ IN: farkup.tests [ ] [ "[{}]" convert-farkup drop ] unit-test +[ "
hello\n
" ] [ "[{hello}]" convert-farkup ] unit-test + [ "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" ] [ "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 diff --git a/extra/farkup/farkup.factor b/basis/farkup/farkup.factor similarity index 100% rename from extra/farkup/farkup.factor rename to basis/farkup/farkup.factor diff --git a/extra/farkup/summary.txt b/basis/farkup/summary.txt similarity index 100% rename from extra/farkup/summary.txt rename to basis/farkup/summary.txt diff --git a/extra/farkup/tags.txt b/basis/farkup/tags.txt similarity index 100% rename from extra/farkup/tags.txt rename to basis/farkup/tags.txt diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor index 28eea4701e..411643ddc0 100755 --- a/basis/float-arrays/float-arrays.factor +++ b/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 ; diff --git a/basis/float-vectors/float-vectors-tests.factor b/basis/float-vectors/float-vectors-tests.factor index 383dd4bcf2..1483b269e0 100755 --- a/basis/float-vectors/float-vectors-tests.factor +++ b/basis/float-vectors/float-vectors-tests.factor @@ -1,10 +1,10 @@ +USING: tools.test float-vectors vectors sequences kernel math ; IN: float-vectors.tests -USING: tools.test float-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test : do-it - 12345 [ over push ] each ; + 12345 [ >float over push ] each ; [ t ] [ 3 do-it diff --git a/basis/float-vectors/float-vectors.factor b/basis/float-vectors/float-vectors.factor index 68b692da5a..8e93582f04 100755 --- a/basis/float-vectors/float-vectors.factor +++ b/basis/float-vectors/float-vectors.factor @@ -34,5 +34,5 @@ INSTANCE: float-vector growable : FV{ \ } [ >float-vector ] parse-literal ; parsing M: float-vector >pprint-sequence ; - M: float-vector pprint-delims drop \ FV{ \ } ; +M: float-vector pprint* pprint-object ; diff --git a/extra/furnace/actions/actions-tests.factor b/basis/furnace/actions/actions-tests.factor similarity index 100% rename from extra/furnace/actions/actions-tests.factor rename to basis/furnace/actions/actions-tests.factor diff --git a/extra/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor similarity index 100% rename from extra/furnace/actions/actions.factor rename to basis/furnace/actions/actions.factor diff --git a/extra/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor similarity index 100% rename from extra/furnace/alloy/alloy.factor rename to basis/furnace/alloy/alloy.factor diff --git a/extra/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor similarity index 100% rename from extra/furnace/auth/auth-tests.factor rename to basis/furnace/auth/auth-tests.factor diff --git a/extra/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor similarity index 100% rename from extra/furnace/auth/auth.factor rename to basis/furnace/auth/auth.factor diff --git a/extra/furnace/auth/basic/basic.factor b/basis/furnace/auth/basic/basic.factor similarity index 100% rename from extra/furnace/auth/basic/basic.factor rename to basis/furnace/auth/basic/basic.factor diff --git a/extra/furnace/auth/boilerplate.xml b/basis/furnace/auth/boilerplate.xml similarity index 100% rename from extra/furnace/auth/boilerplate.xml rename to basis/furnace/auth/boilerplate.xml diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user.factor similarity index 100% rename from extra/furnace/auth/features/deactivate-user/deactivate-user.factor rename to basis/furnace/auth/features/deactivate-user/deactivate-user.factor diff --git a/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor similarity index 100% rename from extra/furnace/auth/features/edit-profile/edit-profile-tests.factor rename to basis/furnace/auth/features/edit-profile/edit-profile-tests.factor diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor similarity index 100% rename from extra/furnace/auth/features/edit-profile/edit-profile.factor rename to basis/furnace/auth/features/edit-profile/edit-profile.factor diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.xml b/basis/furnace/auth/features/edit-profile/edit-profile.xml similarity index 100% rename from extra/furnace/auth/features/edit-profile/edit-profile.xml rename to basis/furnace/auth/features/edit-profile/edit-profile.xml diff --git a/extra/furnace/auth/features/recover-password/recover-1.xml b/basis/furnace/auth/features/recover-password/recover-1.xml similarity index 100% rename from extra/furnace/auth/features/recover-password/recover-1.xml rename to basis/furnace/auth/features/recover-password/recover-1.xml diff --git a/extra/furnace/auth/features/recover-password/recover-2.xml b/basis/furnace/auth/features/recover-password/recover-2.xml similarity index 100% rename from extra/furnace/auth/features/recover-password/recover-2.xml rename to basis/furnace/auth/features/recover-password/recover-2.xml diff --git a/extra/furnace/auth/features/recover-password/recover-3.xml b/basis/furnace/auth/features/recover-password/recover-3.xml similarity index 100% rename from extra/furnace/auth/features/recover-password/recover-3.xml rename to basis/furnace/auth/features/recover-password/recover-3.xml diff --git a/extra/furnace/auth/features/recover-password/recover-4.xml b/basis/furnace/auth/features/recover-password/recover-4.xml similarity index 100% rename from extra/furnace/auth/features/recover-password/recover-4.xml rename to basis/furnace/auth/features/recover-password/recover-4.xml diff --git a/extra/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor similarity index 100% rename from extra/furnace/auth/features/recover-password/recover-password-tests.factor rename to basis/furnace/auth/features/recover-password/recover-password-tests.factor diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor similarity index 100% rename from extra/furnace/auth/features/recover-password/recover-password.factor rename to basis/furnace/auth/features/recover-password/recover-password.factor diff --git a/extra/furnace/auth/features/registration/register.xml b/basis/furnace/auth/features/registration/register.xml similarity index 100% rename from extra/furnace/auth/features/registration/register.xml rename to basis/furnace/auth/features/registration/register.xml diff --git a/extra/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor similarity index 100% rename from extra/furnace/auth/features/registration/registration-tests.factor rename to basis/furnace/auth/features/registration/registration-tests.factor diff --git a/extra/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor similarity index 100% rename from extra/furnace/auth/features/registration/registration.factor rename to basis/furnace/auth/features/registration/registration.factor diff --git a/extra/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor similarity index 100% rename from extra/furnace/auth/login/login-tests.factor rename to basis/furnace/auth/login/login-tests.factor diff --git a/extra/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor similarity index 100% rename from extra/furnace/auth/login/login.factor rename to basis/furnace/auth/login/login.factor diff --git a/extra/furnace/auth/login/login.xml b/basis/furnace/auth/login/login.xml similarity index 100% rename from extra/furnace/auth/login/login.xml rename to basis/furnace/auth/login/login.xml diff --git a/extra/furnace/auth/login/permits/permits.factor b/basis/furnace/auth/login/permits/permits.factor similarity index 100% rename from extra/furnace/auth/login/permits/permits.factor rename to basis/furnace/auth/login/permits/permits.factor diff --git a/extra/furnace/auth/providers/assoc/assoc-tests.factor b/basis/furnace/auth/providers/assoc/assoc-tests.factor similarity index 100% rename from extra/furnace/auth/providers/assoc/assoc-tests.factor rename to basis/furnace/auth/providers/assoc/assoc-tests.factor diff --git a/extra/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor similarity index 100% rename from extra/furnace/auth/providers/assoc/assoc.factor rename to basis/furnace/auth/providers/assoc/assoc.factor diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor similarity index 100% rename from extra/furnace/auth/providers/db/db-tests.factor rename to basis/furnace/auth/providers/db/db-tests.factor diff --git a/extra/furnace/auth/providers/db/db.factor b/basis/furnace/auth/providers/db/db.factor similarity index 100% rename from extra/furnace/auth/providers/db/db.factor rename to basis/furnace/auth/providers/db/db.factor diff --git a/extra/furnace/auth/providers/null/null.factor b/basis/furnace/auth/providers/null/null.factor similarity index 100% rename from extra/furnace/auth/providers/null/null.factor rename to basis/furnace/auth/providers/null/null.factor diff --git a/extra/furnace/auth/providers/providers.factor b/basis/furnace/auth/providers/providers.factor similarity index 100% rename from extra/furnace/auth/providers/providers.factor rename to basis/furnace/auth/providers/providers.factor diff --git a/extra/furnace/boilerplate/boilerplate.factor b/basis/furnace/boilerplate/boilerplate.factor similarity index 100% rename from extra/furnace/boilerplate/boilerplate.factor rename to basis/furnace/boilerplate/boilerplate.factor diff --git a/extra/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor similarity index 81% rename from extra/furnace/cache/cache.factor rename to basis/furnace/cache/cache.factor index 68786a55ab..a5308c171e 100644 --- a/extra/furnace/cache/cache.factor +++ b/basis/furnace/cache/cache.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors math.intervals -calendar alarms fry +system calendar alarms fry random db db.tuples db.types http.server.filters ; IN: furnace.cache @@ -14,7 +14,7 @@ TUPLE: server-state id expires ; server-state f { { "id" "ID" +random-id+ system-random-generator } - { "expires" "EXPIRES" TIMESTAMP +not-null+ } + { "expires" "EXPIRES" BIG-INTEGER +not-null+ } } define-persistent : get-state ( id class -- state ) @@ -22,7 +22,7 @@ server-state f : expire-state ( class -- ) new - -1.0/0.0 now [a,b] >>expires + -1.0/0.0 millis [a,b] >>expires delete-tuples ; TUPLE: server-state-manager < filter-responder timeout ; @@ -33,4 +33,4 @@ TUPLE: server-state-manager < filter-responder timeout ; 20 minutes >>timeout ; inline : touch-state ( state manager -- ) - timeout>> hence >>expires drop ; + timeout>> hence timestamp>millis >>expires drop ; diff --git a/extra/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor similarity index 100% rename from extra/furnace/conversations/conversations.factor rename to basis/furnace/conversations/conversations.factor diff --git a/extra/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor similarity index 100% rename from extra/furnace/db/db-tests.factor rename to basis/furnace/db/db-tests.factor diff --git a/extra/furnace/db/db.factor b/basis/furnace/db/db.factor similarity index 100% rename from extra/furnace/db/db.factor rename to basis/furnace/db/db.factor diff --git a/extra/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor similarity index 100% rename from extra/furnace/furnace-tests.factor rename to basis/furnace/furnace-tests.factor diff --git a/extra/furnace/furnace.factor b/basis/furnace/furnace.factor similarity index 93% rename from extra/furnace/furnace.factor rename to basis/furnace/furnace.factor index 45aa55f050..fadd398882 100644 --- a/extra/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -176,7 +176,7 @@ CHLOE: a [ link-attrs ] [ "method" optional-attr "post" or =method ] [ "action" required-attr resolve-base-path =action ] - [ tag-attrs non-chloe-attrs-only print-attrs ] + [ attrs>> non-chloe-attrs-only print-attrs ] } cleave form> ] @@ -196,13 +196,13 @@ STRING: button-tag-markup ; : add-tag-attrs ( attrs tag -- ) - tag-attrs swap update ; + attrs>> swap update ; CHLOE: button - button-tag-markup string>xml delegate + button-tag-markup string>xml body>> { - [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] - [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] - [ [ children>string 1array ] dip "button" tag-named set-tag-children ] + [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] + [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ children>string 1array ] dip "button" tag-named (>>children) ] [ nip ] } 2cleave process-chloe-tag ; diff --git a/extra/furnace/json/json.factor b/basis/furnace/json/json.factor similarity index 100% rename from extra/furnace/json/json.factor rename to basis/furnace/json/json.factor diff --git a/extra/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor similarity index 100% rename from extra/furnace/redirection/redirection.factor rename to basis/furnace/redirection/redirection.factor diff --git a/extra/furnace/referrer/referrer.factor b/basis/furnace/referrer/referrer.factor similarity index 67% rename from extra/furnace/referrer/referrer.factor rename to basis/furnace/referrer/referrer.factor index 56777676fc..4cfd4bb6c6 100644 --- a/extra/furnace/referrer/referrer.factor +++ b/basis/furnace/referrer/referrer.factor @@ -1,6 +1,7 @@ -USING: accessors kernel -http.server http.server.filters http.server.responses -furnace ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel http.server http.server.filters +http.server.responses furnace ; IN: furnace.referrer TUPLE: referrer-check < filter-responder quot ; diff --git a/extra/furnace/scopes/scopes.factor b/basis/furnace/scopes/scopes.factor similarity index 100% rename from extra/furnace/scopes/scopes.factor rename to basis/furnace/scopes/scopes.factor diff --git a/basis/units/constants/authors.txt b/basis/furnace/sessions/authors.txt similarity index 100% rename from basis/units/constants/authors.txt rename to basis/furnace/sessions/authors.txt diff --git a/extra/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor similarity index 100% rename from extra/furnace/sessions/sessions-tests.factor rename to basis/furnace/sessions/sessions-tests.factor diff --git a/extra/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor similarity index 100% rename from extra/furnace/sessions/sessions.factor rename to basis/furnace/sessions/sessions.factor diff --git a/extra/furnace/syndication/syndication.factor b/basis/furnace/syndication/syndication.factor similarity index 100% rename from extra/furnace/syndication/syndication.factor rename to basis/furnace/syndication/syndication.factor diff --git a/extra/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor similarity index 100% rename from extra/furnace/utilities/utilities.factor rename to basis/furnace/utilities/utilities.factor diff --git a/basis/math/bitfields/authors.txt b/basis/globs/authors.txt similarity index 100% rename from basis/math/bitfields/authors.txt rename to basis/globs/authors.txt diff --git a/extra/globs/globs-tests.factor b/basis/globs/globs-tests.factor similarity index 100% rename from extra/globs/globs-tests.factor rename to basis/globs/globs-tests.factor diff --git a/extra/globs/globs.factor b/basis/globs/globs.factor similarity index 100% rename from extra/globs/globs.factor rename to basis/globs/globs.factor diff --git a/extra/globs/summary.txt b/basis/globs/summary.txt similarity index 100% rename from extra/globs/summary.txt rename to basis/globs/summary.txt diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 2c894c3812..1b8bcccce7 100755 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -1,6 +1,6 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files -assocs namespaces words io sequences eval ; +assocs namespaces words io sequences eval accessors ; IN: help.definitions.tests [ ] [ \ + >link see ] unit-test @@ -10,7 +10,7 @@ IN: help.definitions.tests "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop - "foo" source-file source-file-definitions first assoc-size + "foo" source-file definitions>> first assoc-size ] unit-test [ t ] [ "hello" articles get key? ] unit-test @@ -23,7 +23,7 @@ IN: help.definitions.tests "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop - "foo" source-file source-file-definitions first assoc-size + "foo" source-file definitions>> first assoc-size ] unit-test [ t ] [ "hello" articles get key? ] unit-test diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index d329fa5d42..643e121f5e 100755 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -14,6 +14,7 @@ ARTICLE: "span-elements" "Span elements" { $subsection $link } { $subsection $vocab-link } { $subsection $snippet } +{ $subsection $slot } { $subsection $url } ; ARTICLE: "block-elements" "Block elements" @@ -212,6 +213,18 @@ HELP: $code { $markup-example { $code "2 2 + ." } } } ; +HELP: $nl +{ $values { "children" "unused parameter" } } +{ $description "Prints a paragraph break. The parameter is unused." } ; + +HELP: $snippet +{ $values { "children" "markup elements" } } +{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." } ; + +HELP: $slot +{ $values { "children" "markup elements" } } +{ $description "Prints a tuple slot name in the same way as a snippet. The help tool can check that there exists an accessor with this name." } ; + HELP: $vocabulary { $values { "element" "a markup element of the form " { $snippet "{ word }" } } } { $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ; @@ -399,5 +412,5 @@ HELP: ABOUT: { $description "Defines the main documentation article for the current vocabulary." } ; HELP: vocab-help -{ $values { "vocab" "a vocabulary specifier" } { "help" "a help article" } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "help" "a help article" } } { $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT: } "." } ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 14d3420a68..b12dcaa807 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors sequences parser kernel help help.markup +USING: fry accessors sequences parser kernel help help.markup help.topics words strings classes tools.vocabs namespaces io io.streams.string prettyprint definitions arrays vectors combinators combinators.short-circuit splitting debugger @@ -39,7 +39,7 @@ IN: help.lint $predicate $class-description $error-description - } swap [ elements f like ] curry contains? ; + } swap '[ , elements empty? not ] contains? ; : check-values ( word element -- ) { @@ -108,12 +108,10 @@ M: help-error error. articles get keys vocabs [ dup vocab-docs-path swap ] H{ } map>assoc H{ } clone [ - [ - [ dup >link where dup ] 2dip - [ >r >r first r> at r> push-at ] 2curry - [ 2drop ] - if - ] 2curry each + '[ + dup >link where dup + [ first , at , push-at ] [ 2drop ] if + ] each ] keep ; : check-about ( vocab -- ) diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 6b138a18ab..222c4e7d3f 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -1,13 +1,13 @@ USING: definitions help help.markup kernel sequences tools.test -words parser namespaces assocs generic io.streams.string ; +words parser namespaces assocs generic io.streams.string accessors ; IN: help.markup.tests TUPLE: blahblah quux ; [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test -[ ] [ \ blahblah-quux help ] unit-test -[ ] [ \ set-blahblah-quux help ] unit-test +[ ] [ \ quux>> help ] unit-test +[ ] [ \ >>quux help ] unit-test [ ] [ \ blahblah? help ] unit-test : fooey "fooey" throw ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index d65eb8fc88..d94b9c4b41 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -3,7 +3,7 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots -vocabs help.stylesheet help.topics vocabs.loader ; +vocabs help.stylesheet help.topics vocabs.loader alias ; IN: help.markup ! Simple markup language. @@ -61,6 +61,9 @@ M: f print-element drop ; : $snippet ( children -- ) [ snippet-style get print-element* ] ($span) ; +! for help-lint +ALIAS: $slot $snippet + : $emphasis ( children -- ) [ emphasis-style get print-element* ] ($span) ; diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor index 68306263a5..e7438edd4d 100755 --- a/basis/help/syntax/syntax-tests.factor +++ b/basis/help/syntax/syntax-tests.factor @@ -1,5 +1,6 @@ +USING: kernel tools.test parser vocabs help.syntax namespaces +eval accessors ; IN: help.syntax.tests -USING: tools.test parser vocabs help.syntax namespaces eval ; [ [ "foobar" ] [ @@ -12,5 +13,5 @@ USING: tools.test parser vocabs help.syntax namespaces eval ; "help.syntax.tests" vocab vocab-help ] unit-test - [ ] [ f "help.syntax.tests" vocab set-vocab-help ] unit-test + [ ] [ "help.syntax.tests" vocab f >>help drop ] unit-test ] with-file-vocabs diff --git a/basis/help/topics/topics-docs.factor b/basis/help/topics/topics-docs.factor index f2f3e8e82f..08195ee07d 100644 --- a/basis/help/topics/topics-docs.factor +++ b/basis/help/topics/topics-docs.factor @@ -1,5 +1,6 @@ -USING: help.markup help.syntax help.topics help.crossref help io -io.styles hashtables ; +USING: help.markup help.syntax help.crossref help io io.styles +hashtables strings ; +IN: help.topics HELP: articles { $var-description "Hashtable mapping article names to " { $link article } " instances." } ; @@ -14,11 +15,11 @@ HELP: article { $description "Outputs a named " { $link article } " object." } ; HELP: article-title -{ $values { "article" "an article name or a word" } { "title" "a string" } } +{ $values { "topic" "an article name or a word" } { "string" string } } { $description "Outputs the title of a specific help article." } ; HELP: article-content -{ $values { "article" "an article name or a word" } { "content" "a markup element" } } +{ $values { "topic" "an article name or a word" } { "content" "a markup element" } } { $description "Outputs the content of a specific help article." } ; HELP: all-articles diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index c52d5e347f..f53bdee9c7 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -1,6 +1,6 @@ -USING: definitions help help.topics help.crossref help.markup -help.syntax kernel sequences tools.test words parser namespaces -assocs source-files eval ; +USING: accessors definitions help help.topics help.crossref +help.markup help.syntax kernel sequences tools.test words parser +namespaces assocs source-files eval ; IN: help.topics.tests \ article-name must-infer @@ -16,7 +16,7 @@ IN: help.topics.tests SYMBOL: foo -[ ] [ { "test" "a" } "Test A" { { $subsection foo } }
add-article ] unit-test +[ ] [ "Test A" { { $subsection foo } }
{ "test" "a" } add-article ] unit-test ! Test article location recording diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index e6ca1ff26b..99c4a2ddfc 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -12,7 +12,6 @@ $nl $nl "Type hints are declared with a parsing word:" { $subsection POSTPONE: HINTS: } -$nl "The specialized version of a word which will be compiled by the compiler can be inspected:" { $subsection specialized-def } ; diff --git a/extra/html/components/components-tests.factor b/basis/html/components/components-tests.factor similarity index 100% rename from extra/html/components/components-tests.factor rename to basis/html/components/components-tests.factor diff --git a/extra/html/components/components.factor b/basis/html/components/components.factor similarity index 100% rename from extra/html/components/components.factor rename to basis/html/components/components.factor diff --git a/extra/html/elements/authors.txt b/basis/html/elements/authors.txt similarity index 100% rename from extra/html/elements/authors.txt rename to basis/html/elements/authors.txt diff --git a/extra/html/elements/elements-tests.factor b/basis/html/elements/elements-tests.factor similarity index 100% rename from extra/html/elements/elements-tests.factor rename to basis/html/elements/elements-tests.factor diff --git a/extra/html/elements/elements.factor b/basis/html/elements/elements.factor similarity index 100% rename from extra/html/elements/elements.factor rename to basis/html/elements/elements.factor diff --git a/extra/html/forms/forms-tests.factor b/basis/html/forms/forms-tests.factor similarity index 100% rename from extra/html/forms/forms-tests.factor rename to basis/html/forms/forms-tests.factor diff --git a/extra/html/forms/forms.factor b/basis/html/forms/forms.factor similarity index 97% rename from extra/html/forms/forms.factor rename to basis/html/forms/forms.factor index 0da3fcb0b3..911e545f87 100644 --- a/extra/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables -mirrors math fry sequences sequences.lib words continuations ; +mirrors math fry sequences words continuations ; IN: html.forms TUPLE: form errors values validation-failed ; diff --git a/extra/html/streams/authors.txt b/basis/html/streams/authors.txt similarity index 100% rename from extra/html/streams/authors.txt rename to basis/html/streams/authors.txt diff --git a/extra/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor similarity index 86% rename from extra/html/streams/streams-tests.factor rename to basis/html/streams/streams-tests.factor index 948c998e13..b5707c158f 100644 --- a/extra/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -1,8 +1,6 @@ - -USING: html.streams html.streams.private - io io.streams.string io.styles kernel - namespaces tools.test xml.writer sbufs sequences inspector colors ; - +USING: html.streams html.streams.private accessors io +io.streams.string io.styles kernel namespaces tools.test +xml.writer sbufs sequences inspector colors ; IN: html.streams.tests : make-html-string @@ -33,7 +31,7 @@ IN: html.streams.tests TUPLE: funky town ; M: funky browser-link-href - "http://www.funky-town.com/" swap funky-town append ; + "http://www.funky-town.com/" swap town>> append ; [ "<" ] [ [ diff --git a/extra/html/streams/streams.factor b/basis/html/streams/streams.factor similarity index 100% rename from extra/html/streams/streams.factor rename to basis/html/streams/streams.factor diff --git a/extra/html/streams/summary.txt b/basis/html/streams/summary.txt similarity index 100% rename from extra/html/streams/summary.txt rename to basis/html/streams/summary.txt diff --git a/extra/html/streams/tags.txt b/basis/html/streams/tags.txt similarity index 100% rename from extra/html/streams/tags.txt rename to basis/html/streams/tags.txt diff --git a/extra/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor similarity index 98% rename from extra/html/templates/chloe/chloe-tests.factor rename to basis/html/templates/chloe/chloe-tests.factor index 4048836cfe..0305b738af 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -26,7 +26,7 @@ IN: html.templates.chloe.tests "?>" split1 nip ; inline : test-template ( name -- template ) - "resource:extra/html/templates/chloe/test/" + "resource:basis/html/templates/chloe/test/" prepend ; [ "Hello world" ] [ diff --git a/extra/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor similarity index 92% rename from extra/html/templates/chloe/chloe.factor rename to basis/html/templates/chloe/chloe.factor index 67a7dc2045..f40fc43b32 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -3,7 +3,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls present +unicode.case mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities html.forms html.elements @@ -22,10 +22,10 @@ C: chloe DEFER: process-template : chloe-attrs-only ( assoc -- assoc' ) - [ drop name-url chloe-ns = ] assoc-filter ; + [ drop url>> chloe-ns = ] assoc-filter ; : non-chloe-attrs-only ( assoc -- assoc' ) - [ drop name-url chloe-ns = not ] assoc-filter ; + [ drop url>> chloe-ns = not ] assoc-filter ; : chloe-tag? ( tag -- ? ) dup xml? [ body>> ] when @@ -148,10 +148,10 @@ CHLOE-TUPLE: code process-template ] [ { - [ xml-prolog write-prolog ] - [ xml-before write-chunk ] + [ prolog>> write-prolog ] + [ before>> write-chunk ] [ process-template ] - [ xml-after write-chunk ] + [ after>> write-chunk ] } cleave ] if ] with-scope ; diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor similarity index 96% rename from extra/html/templates/chloe/syntax/syntax.factor rename to basis/html/templates/chloe/syntax/syntax.factor index 82309a49b2..65b5cd8790 100644 --- a/extra/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -4,7 +4,7 @@ IN: html.templates.chloe.syntax USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls +unicode.case mirrors fry math urls multiline xml xml.data xml.writer xml.utilities html.elements html.components diff --git a/extra/html/templates/chloe/test/test1.xml b/basis/html/templates/chloe/test/test1.xml similarity index 100% rename from extra/html/templates/chloe/test/test1.xml rename to basis/html/templates/chloe/test/test1.xml diff --git a/extra/html/templates/chloe/test/test10.xml b/basis/html/templates/chloe/test/test10.xml similarity index 100% rename from extra/html/templates/chloe/test/test10.xml rename to basis/html/templates/chloe/test/test10.xml diff --git a/extra/html/templates/chloe/test/test11.xml b/basis/html/templates/chloe/test/test11.xml similarity index 100% rename from extra/html/templates/chloe/test/test11.xml rename to basis/html/templates/chloe/test/test11.xml diff --git a/extra/html/templates/chloe/test/test12.xml b/basis/html/templates/chloe/test/test12.xml similarity index 100% rename from extra/html/templates/chloe/test/test12.xml rename to basis/html/templates/chloe/test/test12.xml diff --git a/extra/html/templates/chloe/test/test2.xml b/basis/html/templates/chloe/test/test2.xml similarity index 100% rename from extra/html/templates/chloe/test/test2.xml rename to basis/html/templates/chloe/test/test2.xml diff --git a/extra/html/templates/chloe/test/test3-aux.xml b/basis/html/templates/chloe/test/test3-aux.xml similarity index 100% rename from extra/html/templates/chloe/test/test3-aux.xml rename to basis/html/templates/chloe/test/test3-aux.xml diff --git a/extra/html/templates/chloe/test/test3.xml b/basis/html/templates/chloe/test/test3.xml similarity index 100% rename from extra/html/templates/chloe/test/test3.xml rename to basis/html/templates/chloe/test/test3.xml diff --git a/extra/html/templates/chloe/test/test4.xml b/basis/html/templates/chloe/test/test4.xml similarity index 100% rename from extra/html/templates/chloe/test/test4.xml rename to basis/html/templates/chloe/test/test4.xml diff --git a/extra/html/templates/chloe/test/test5.xml b/basis/html/templates/chloe/test/test5.xml similarity index 100% rename from extra/html/templates/chloe/test/test5.xml rename to basis/html/templates/chloe/test/test5.xml diff --git a/extra/html/templates/chloe/test/test6.xml b/basis/html/templates/chloe/test/test6.xml similarity index 100% rename from extra/html/templates/chloe/test/test6.xml rename to basis/html/templates/chloe/test/test6.xml diff --git a/extra/html/templates/chloe/test/test7.xml b/basis/html/templates/chloe/test/test7.xml similarity index 100% rename from extra/html/templates/chloe/test/test7.xml rename to basis/html/templates/chloe/test/test7.xml diff --git a/extra/html/templates/chloe/test/test8.xml b/basis/html/templates/chloe/test/test8.xml similarity index 100% rename from extra/html/templates/chloe/test/test8.xml rename to basis/html/templates/chloe/test/test8.xml diff --git a/extra/html/templates/chloe/test/test9.xml b/basis/html/templates/chloe/test/test9.xml similarity index 100% rename from extra/html/templates/chloe/test/test9.xml rename to basis/html/templates/chloe/test/test9.xml diff --git a/extra/html/templates/fhtml/authors.txt b/basis/html/templates/fhtml/authors.txt similarity index 100% rename from extra/html/templates/fhtml/authors.txt rename to basis/html/templates/fhtml/authors.txt diff --git a/extra/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor similarity index 91% rename from extra/html/templates/fhtml/fhtml-tests.factor rename to basis/html/templates/fhtml/fhtml-tests.factor index 43ea28fa55..b863087a92 100755 --- a/extra/html/templates/fhtml/fhtml-tests.factor +++ b/basis/html/templates/fhtml/fhtml-tests.factor @@ -4,7 +4,7 @@ tools.test sequences parser ; IN: html.templates.fhtml.tests : test-template ( path -- ? ) - "resource:extra/html/templates/fhtml/test/" + "resource:basis/html/templates/fhtml/test/" prepend [ ".fhtml" append [ call-template ] with-string-writer diff --git a/extra/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor similarity index 100% rename from extra/html/templates/fhtml/fhtml.factor rename to basis/html/templates/fhtml/fhtml.factor diff --git a/extra/html/templates/fhtml/test/bug.fhtml b/basis/html/templates/fhtml/test/bug.fhtml similarity index 100% rename from extra/html/templates/fhtml/test/bug.fhtml rename to basis/html/templates/fhtml/test/bug.fhtml diff --git a/extra/html/templates/fhtml/test/bug.html b/basis/html/templates/fhtml/test/bug.html similarity index 100% rename from extra/html/templates/fhtml/test/bug.html rename to basis/html/templates/fhtml/test/bug.html diff --git a/extra/html/templates/fhtml/test/example.fhtml b/basis/html/templates/fhtml/test/example.fhtml similarity index 100% rename from extra/html/templates/fhtml/test/example.fhtml rename to basis/html/templates/fhtml/test/example.fhtml diff --git a/extra/html/templates/fhtml/test/example.html b/basis/html/templates/fhtml/test/example.html similarity index 100% rename from extra/html/templates/fhtml/test/example.html rename to basis/html/templates/fhtml/test/example.html diff --git a/extra/html/templates/fhtml/test/stack.fhtml b/basis/html/templates/fhtml/test/stack.fhtml similarity index 100% rename from extra/html/templates/fhtml/test/stack.fhtml rename to basis/html/templates/fhtml/test/stack.fhtml diff --git a/extra/html/templates/fhtml/test/stack.html b/basis/html/templates/fhtml/test/stack.html similarity index 100% rename from extra/html/templates/fhtml/test/stack.html rename to basis/html/templates/fhtml/test/stack.html diff --git a/extra/html/templates/templates.factor b/basis/html/templates/templates.factor similarity index 100% rename from extra/html/templates/templates.factor rename to basis/html/templates/templates.factor diff --git a/extra/globs/authors.txt b/basis/http/authors.txt similarity index 100% rename from extra/globs/authors.txt rename to basis/http/authors.txt diff --git a/extra/http/authors.txt b/basis/http/client/authors.txt similarity index 100% rename from extra/http/authors.txt rename to basis/http/client/authors.txt diff --git a/extra/http/client/client-tests.factor b/basis/http/client/client-tests.factor similarity index 51% rename from extra/http/client/client-tests.factor rename to basis/http/client/client-tests.factor index 28a605174a..1219ae0b97 100755 --- a/extra/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,5 +1,5 @@ USING: http.client http.client.private http tools.test -tuple-syntax namespaces urls ; +namespaces urls ; [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test @@ -9,12 +9,12 @@ tuple-syntax namespaces urls ; [ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test [ - TUPLE{ request - url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" } - method: "GET" - version: "1.1" - cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } + T{ request + { url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } } + { method "GET" } + { version "1.1" } + { cookies V{ } } + { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } } ] [ "http://www.apple.com/index.html" @@ -22,12 +22,12 @@ tuple-syntax namespaces urls ; ] unit-test [ - TUPLE{ request - url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" } - method: "GET" - version: "1.1" - cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } + T{ request + { url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } } + { method "GET" } + { version "1.1" } + { cookies V{ } } + { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } } ] [ "https://www.amazon.com/index.html" diff --git a/extra/http/client/client.factor b/basis/http/client/client.factor similarity index 97% rename from extra/http/client/client.factor rename to basis/http/client/client.factor index 10b9206a51..8dc1924a12 100755 --- a/extra/http/client/client.factor +++ b/basis/http/client/client.factor @@ -95,7 +95,7 @@ DEFER: (http-request) SYMBOL: redirects : redirect-url ( request url -- request ) - '[ , >url ensure-port derive-url ensure-port ] change-url ; + '[ , >url derive-url ensure-port ] change-url ; : do-redirect ( response data -- response data ) over code>> 300 399 between? [ @@ -113,7 +113,7 @@ SYMBOL: redirects PRIVATE> : read-chunk-size ( -- n ) - read-crlf ";" split1 drop [ blank? ] right-trim + read-crlf ";" split1 drop [ blank? ] trim-right hex> [ "Bad chunk size" throw ] unless* ; : read-chunks ( -- ) diff --git a/extra/http/client/summary.txt b/basis/http/client/summary.txt similarity index 100% rename from extra/http/client/summary.txt rename to basis/http/client/summary.txt diff --git a/extra/http/client/tags.txt b/basis/http/client/tags.txt similarity index 100% rename from extra/http/client/tags.txt rename to basis/http/client/tags.txt diff --git a/extra/http/http-tests.factor b/basis/http/http-tests.factor similarity index 81% rename from extra/http/http-tests.factor rename to basis/http/http-tests.factor index bbf8161dd7..3294940d89 100755 --- a/extra/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,8 +1,8 @@ USING: http http.server http.client tools.test multiline -tuple-syntax io.streams.string io.encodings.utf8 -io.encodings.8-bit io.encodings.binary io.encodings.string -kernel arrays splitting sequences assocs io.sockets db db.sqlite -continuations urls hashtables accessors ; +io.streams.string io.encodings.utf8 io.encodings.8-bit +io.encodings.binary io.encodings.string kernel arrays splitting +sequences assocs io.sockets db db.sqlite continuations urls +hashtables accessors ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -24,13 +24,13 @@ blah ; [ - TUPLE{ request - url: TUPLE{ url path: "/bar" } - method: "POST" - version: "1.1" - header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } - post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" } - cookies: V{ } + T{ request + { url T{ url { path "/bar" } } } + { method "POST" } + { version "1.1" } + { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } } + { post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } } + { cookies V{ } } } ] [ read-request-test-1 lf>crlf [ @@ -62,12 +62,12 @@ Host: www.sex.com ; [ - TUPLE{ request - url: TUPLE{ url host: "www.sex.com" path: "/bar" } - method: "HEAD" - version: "1.1" - header: H{ { "host" "www.sex.com" } } - cookies: V{ } + T{ request + { url T{ url { host "www.sex.com" } { path "/bar" } } } + { method "HEAD" } + { version "1.1" } + { header H{ { "host" "www.sex.com" } } } + { cookies V{ } } } ] [ read-request-test-2 lf>crlf [ @@ -103,14 +103,14 @@ blah ; [ - TUPLE{ response - version: "1.1" - code: 404 - message: "not found" - header: H{ { "content-type" "text/html; charset=UTF-8" } } - cookies: { } - content-type: "text/html" - content-charset: utf8 + T{ response + { version "1.1" } + { code 404 } + { message "not found" } + { header H{ { "content-type" "text/html; charset=UTF-8" } } } + { cookies { } } + { content-type "text/html" } + { content-charset utf8 } } ] [ read-response-test-1 lf>crlf @@ -202,7 +202,7 @@ test-db [ add-quit-action - "resource:extra/http/test" >>default + "resource:basis/http/test" >>default "nested" add-responder [ URL" redirect-loop" ] >>display @@ -214,7 +214,7 @@ test-db [ ] unit-test [ t ] [ - "resource:extra/http/test/foo.html" ascii file-contents + "resource:basis/http/test/foo.html" ascii file-contents "http://localhost:1237/nested/foo.html" http-get nip = ] unit-test @@ -225,6 +225,28 @@ test-db [ "http://localhost:1237/quit" http-get nip ] unit-test +! HTTP client redirect bug +[ ] [ + [ + + add-quit-action + [ "quit" ] >>display + "redirect" add-responder + main-responder set + + test-httpd + ] with-scope +] unit-test + +[ "Goodbye" ] [ + "http://localhost:1237/redirect" http-get nip +] unit-test + + +[ ] [ + [ "http://localhost:1237/quit" http-get 2drop ] ignore-errors +] unit-test + ! Dispatcher bugs [ ] [ [ diff --git a/extra/http/http.factor b/basis/http/http.factor similarity index 95% rename from extra/http/http.factor rename to basis/http/http.factor index 70848ed9f6..e450631d94 100755 --- a/extra/http/http.factor +++ b/basis/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel combinators math namespaces -assocs assocs.lib sequences splitting sorting sets debugger +assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present @@ -27,9 +27,12 @@ IN: http : (read-header) ( -- alist ) [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; +: collect-headers ( assoc -- assoc' ) + H{ } clone [ '[ , push-at ] assoc-each ] keep ; + : process-header ( alist -- assoc ) f swap [ [ swap or dup ] dip swap ] assoc-map nip - [ ?push ] histogram [ "; " join ] assoc-map + collect-headers [ "; " join ] assoc-map >hashtable ; : read-header ( -- assoc ) @@ -106,7 +109,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s [ { { [ dup timestamp? ] [ timestamp>cookie-string ] } - { [ dup duration? ] [ dt>seconds number>string ] } + { [ dup duration? ] [ duration>seconds number>string ] } { [ dup real? ] [ number>string ] } [ ] } cond diff --git a/extra/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor similarity index 97% rename from extra/http/parsers/parsers.factor rename to basis/http/parsers/parsers.factor index 746741c894..2a31373951 100644 --- a/extra/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit math math.order math.parser kernel sequences sequences.deep peg peg.parsers assocs arrays hashtables strings unicode.case namespaces ascii ; diff --git a/extra/http/client/authors.txt b/basis/http/server/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/http/client/authors.txt rename to basis/http/server/authors.txt diff --git a/extra/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor similarity index 100% rename from extra/http/server/cgi/cgi.factor rename to basis/http/server/cgi/cgi.factor diff --git a/extra/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor similarity index 100% rename from extra/http/server/dispatchers/dispatchers-tests.factor rename to basis/http/server/dispatchers/dispatchers-tests.factor diff --git a/extra/http/server/dispatchers/dispatchers.factor b/basis/http/server/dispatchers/dispatchers.factor similarity index 100% rename from extra/http/server/dispatchers/dispatchers.factor rename to basis/http/server/dispatchers/dispatchers.factor diff --git a/extra/http/server/filters/filters.factor b/basis/http/server/filters/filters.factor similarity index 100% rename from extra/http/server/filters/filters.factor rename to basis/http/server/filters/filters.factor diff --git a/extra/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor similarity index 100% rename from extra/http/server/redirection/redirection-tests.factor rename to basis/http/server/redirection/redirection-tests.factor diff --git a/extra/http/server/redirection/redirection.factor b/basis/http/server/redirection/redirection.factor similarity index 100% rename from extra/http/server/redirection/redirection.factor rename to basis/http/server/redirection/redirection.factor diff --git a/extra/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor similarity index 100% rename from extra/http/server/responses/responses.factor rename to basis/http/server/responses/responses.factor diff --git a/extra/http/server/server-tests.factor b/basis/http/server/server-tests.factor similarity index 100% rename from extra/http/server/server-tests.factor rename to basis/http/server/server-tests.factor diff --git a/extra/http/server/server.factor b/basis/http/server/server.factor similarity index 100% rename from extra/http/server/server.factor rename to basis/http/server/server.factor diff --git a/extra/http/server/static/static.factor b/basis/http/server/static/static.factor similarity index 93% rename from extra/http/server/static/static.factor rename to basis/http/server/static/static.factor index 98510e45fd..dfbe93d86d 100755 --- a/extra/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> right-trim-separators + file-responder get root>> trim-right-separators "/" - rot "" or left-trim-separators 3append ; + rot "" or trim-left-separators 3append ; : serve-file ( filename -- response ) dup mime-type diff --git a/extra/http/server/summary.txt b/basis/http/server/summary.txt similarity index 100% rename from extra/http/server/summary.txt rename to basis/http/server/summary.txt diff --git a/extra/http/server/tags.txt b/basis/http/server/tags.txt similarity index 100% rename from extra/http/server/tags.txt rename to basis/http/server/tags.txt diff --git a/extra/http/summary.txt b/basis/http/summary.txt similarity index 100% rename from extra/http/summary.txt rename to basis/http/summary.txt diff --git a/extra/http/tags.txt b/basis/http/tags.txt similarity index 100% rename from extra/http/tags.txt rename to basis/http/tags.txt diff --git a/extra/http/test/foo.html b/basis/http/test/foo.html similarity index 100% rename from extra/http/test/foo.html rename to basis/http/test/foo.html diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index 74a1797efc..b3c5c4ee90 100755 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -4,7 +4,7 @@ sequences tools.test namespaces byte-arrays strings accessors destructors ; : buffer-set ( string buffer -- ) - over >byte-array over buffer-ptr byte-array>memory + over >byte-array over ptr>> byte-array>memory >r length r> buffer-reset ; : string>buffer ( string -- buffer ) diff --git a/basis/io/encodings/ascii/ascii-docs.factor b/basis/io/encodings/ascii/ascii-docs.factor index 9c9c3a5234..fa496a3526 100644 --- a/basis/io/encodings/ascii/ascii-docs.factor +++ b/basis/io/encodings/ascii/ascii-docs.factor @@ -2,5 +2,10 @@ USING: help.markup help.syntax ; IN: io.encodings.ascii HELP: ascii -{ $class-description "This is the encoding descriptor which denotes an ASCII encoding. By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." } -{ $see-also "encodings-introduction" } ; +{ $class-description "ASCII encoding descriptor." } ; + +ARTICLE: "ascii" "ASCII encoding" +"By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." +{ $subsection ascii } ; + +ABOUT: "ascii" diff --git a/basis/io/encodings/utf16/utf16-docs.factor b/basis/io/encodings/utf16/utf16-docs.factor index f37a9d1d58..dc499b5ed4 100644 --- a/basis/io/encodings/utf16/utf16-docs.factor +++ b/basis/io/encodings/utf16/utf16-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax io.encodings strings ; IN: io.encodings.utf16 -ARTICLE: "io.encodings.utf16" "UTF-16" +ARTICLE: "io.encodings.utf16" "UTF-16 encoding" "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" { $subsection utf16 } { $subsection utf16le } diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index 63381811d1..1cc97753b7 100755 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -54,7 +54,7 @@ os { winnt linux macosx } member? [ "m" get next-change drop dup print flush dup parent-directory - [ right-trim-separators "xyz" tail? ] either? not + [ trim-right-separators "xyz" tail? ] either? not ] loop "c1" get count-down @@ -63,7 +63,7 @@ os { winnt linux macosx } member? [ "m" get next-change drop dup print flush dup parent-directory - [ right-trim-separators "yxy" tail? ] either? not + [ trim-right-separators "yxy" tail? ] either? not ] loop "c2" get count-down diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index 84e0d684ac..aa8df0b16c 100755 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -13,7 +13,7 @@ concurrency.promises io.encodings.ascii io threads calendar ; ] unit-test [ t ] [ - T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 } + T{ inet4 f "1.2.3.4" 1234 } T{ inet4 f "1.2.3.5" 1235 } [ log-connection ] 2keep [ remote-address get = ] [ local-address get = ] bi* and diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 9968014993..79a1abd49c 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -72,22 +72,14 @@ M: inet4 sockaddr-type drop "sockaddr-in" c-type ; M: inet4 make-sockaddr ( inet -- sockaddr ) "sockaddr-in" AF_INET over set-sockaddr-in-family - over inet4-port htons over set-sockaddr-in-port - over inet4-host + over port>> htons over set-sockaddr-in-port + over host>> "0.0.0.0" or rot inet-pton *uint over set-sockaddr-in-addr ; - - M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs (port) ; + swap sockaddr-in-port ntohs ; TUPLE: inet6 host port ; @@ -134,13 +126,13 @@ M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; M: inet6 make-sockaddr ( inet -- sockaddr ) "sockaddr-in6" AF_INET6 over set-sockaddr-in6-family - over inet6-port htons over set-sockaddr-in6-port - over inet6-host "::" or + over port>> htons over set-sockaddr-in6-port + over host>> "::" or rot inet-pton over set-sockaddr-in6-addr ; M: inet6 parse-sockaddr >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs (port) ; + swap sockaddr-in6-port ntohs ; : addrspec-of-family ( af -- addrspec ) { @@ -259,17 +251,6 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) [ addrinfo>addrspec ] map sift ; -: prepare-resolve-host ( addrspec -- host' serv' flags ) - #! If the port is a number, we resolve for 'http' then - #! change it later. This is a workaround for a FreeBSD - #! getaddrinfo() limitation -- on Windows, Linux and Mac, - #! we can convert a number to a string and pass that as the - #! service name, but on FreeBSD this gives us an unknown - #! service error. - [ host>> ] - [ port>> dup integer? [ port-override set "http" ] when ] bi - over 0 AI_PASSIVE ? ; - HOOK: addrinfo-error io-backend ( n -- ) GENERIC: resolve-host ( addrspec -- seq ) @@ -278,17 +259,24 @@ TUPLE: inet host port ; C: inet +: resolve-passive-host ( -- addrspecs ) + { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ; + +: prepare-addrinfo ( -- addrinfo ) + "addrinfo" + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol ; + +: fill-in-ports ( addrspecs port -- addrspecs ) + [ >>port ] curry map ; + M: inet resolve-host - [ - prepare-resolve-host - "addrinfo" - [ set-addrinfo-flags ] keep - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo - ] with-scope ; + [ port>> ] [ host>> ] bi [ + f prepare-addrinfo f + [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep freeaddrinfo + ] [ resolve-passive-host ] if* + swap fill-in-ports ; M: f resolve-host drop { } ; diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 63712cd45c..c6eda50855 100755 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations -math.bitfields byte-arrays alien combinators calendar +math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors ; diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index dca2f51958..95e321fd93 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel io.ports io.unix.backend math.bitfields +USING: kernel io.ports io.unix.backend math.bitwise unix io.files.unique.backend system ; IN: io.unix.files.unique diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index 8888d0182f..b3e69a453c 100755 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math math.bitfields namespaces +USING: alien.c-types kernel math math.bitwise namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets unix unix.time unix.kqueue unix.process diff --git a/basis/io/unix/linux/monitors/monitors.factor b/basis/io/unix/linux/monitors/monitors.factor index 5a980266f1..ff23fba0c6 100644 --- a/basis/io/unix/linux/monitors/monitors.factor +++ b/basis/io/unix/linux/monitors/monitors.factor @@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.recursive io.files io.buffers io.monitors io.ports io.timeouts io.unix.backend io.unix.select io.encodings.utf8 unix.linux.inotify assocs namespaces threads continuations init -math math.bitfields sets alien alien.strings alien.c-types +math math.bitwise sets alien alien.strings alien.c-types vocabs.loader accessors system hashtables destructors unix ; IN: io.unix.linux.monitors diff --git a/basis/io/unix/mmap/mmap.factor b/basis/io/unix/mmap/mmap.factor index c31e23849e..d5dcda9436 100755 --- a/basis/io/unix/mmap/mmap.factor +++ b/basis/io/unix/mmap/mmap.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math math.bitfields system unix +USING: alien io io.files kernel math math.bitwise system unix io.unix.backend io.ports io.mmap destructors locals accessors ; IN: io.unix.mmap diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 1377f82ced..5698ab6cf2 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -4,8 +4,7 @@ USING: alien.c-types io.binary io.backend io.files io.buffers io.windows kernel math splitting windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -io.ports destructors accessors -math.bitfields math.bitfields.lib ; +io.ports destructors accessors math.bitwise ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index 9442fa9a72..eabd044bb4 100755 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -6,7 +6,7 @@ windows.types math windows.kernel32 namespaces io.launcher kernel sequences windows.errors splitting system threads init strings combinators io.backend accessors concurrency.flags io.files assocs -io.files.private windows destructors classes.tuple.lib ; +io.files.private windows destructors ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -30,7 +30,19 @@ TUPLE: CreateProcess-args 0 >>dwCreateFlags ; : call-CreateProcess ( CreateProcess-args -- ) - CreateProcess-args >tuple< CreateProcess win32-error=0/f ; + { + [ lpApplicationName>> ] + [ lpCommandLine>> ] + [ lpProcessAttributes>> ] + [ lpThreadAttributes>> ] + [ bInheritHandles>> ] + [ dwCreateFlags>> ] + [ lpEnvironment>> ] + [ lpCurrentDirectory>> ] + [ lpStartupInfo>> ] + [ lpProcessInformation>> ] + } cleave + CreateProcess win32-error=0/f ; : count-trailing-backslashes ( str n -- str n ) >r "\\" ?tail r> swap [ @@ -139,13 +151,13 @@ M: windows kill-process* ( handle -- ) swap win32-error=0/f ; : process-exited ( process -- ) - dup process-handle exit-code - over process-handle dispose-process + dup handle>> exit-code + over handle>> dispose-process notify-exit ; M: windows wait-for-processes ( -- ? ) processes get keys dup - [ process-handle PROCESS_INFORMATION-hProcess ] map + [ handle>> PROCESS_INFORMATION-hProcess ] map dup length swap >c-void*-array 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when diff --git a/basis/io/windows/mmap/mmap.factor b/basis/io/windows/mmap/mmap.factor index 660a4017be..e5b0d10f2f 100755 --- a/basis/io/windows/mmap/mmap.factor +++ b/basis/io/windows/mmap/mmap.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.windows io.windows.files io.windows.privileges -kernel libc math math.bitfields namespaces quotations sequences +kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors locals ; IN: io.windows.mmap diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor index e9df2ddab9..7fbc1dbcf9 100755 --- a/basis/io/windows/nt/backend/backend.factor +++ b/basis/io/windows/nt/backend/backend.factor @@ -1,9 +1,8 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.ports io.timeouts io.windows io.windows.files libc kernel math namespaces -sequences threads classes.tuple.lib windows windows.errors -windows.kernel32 strings splitting io.files -io.buffers qualified ascii system +sequences threads windows windows.errors windows.kernel32 +strings splitting io.files io.buffers qualified ascii system accessors locals ; QUALIFIED: windows.winsock IN: io.windows.nt.backend diff --git a/basis/io/windows/nt/files/files-tests.factor b/basis/io/windows/nt/files/files-tests.factor index 0fa4b4151c..830861eba0 100755 --- a/basis/io/windows/nt/files/files-tests.factor +++ b/basis/io/windows/nt/files/files-tests.factor @@ -21,8 +21,8 @@ IN: io.windows.nt.files.tests [ t ] [ "\\\\" root-directory? ] unit-test [ t ] [ "/" root-directory? ] unit-test [ t ] [ "//" root-directory? ] unit-test -[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test -[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test +[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 6a890f6392..5fbacfa325 100755 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -22,7 +22,7 @@ M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup [ path-separator? ] all? ] [ t ] } - { [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] } + { [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] } [ f ] } cond nip ; diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor index fa4d19a46e..54cb3b1104 100755 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types libc destructors locals kernel math assocs namespaces continuations sequences hashtables -sorting arrays combinators math.bitfields strings system +sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files io.monitors io.ports io.buffers io.files io.timeouts io diff --git a/basis/io/windows/nt/pipes/pipes.factor b/basis/io/windows/nt/pipes/pipes.factor index dc0d7cf1e5..aa52152b75 100755 --- a/basis/io/windows/nt/pipes/pipes.factor +++ b/basis/io/windows/nt/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.windows libc -windows.types math.bitfields windows.kernel32 windows namespaces +windows.types math.bitwise windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random combinators accessors io.pipes io.ports ; IN: io.windows.nt.pipes diff --git a/basis/io/windows/nt/privileges/privileges.factor b/basis/io/windows/nt/privileges/privileges.factor index 007d05f9af..8418d09a5e 100755 --- a/basis/io/windows/nt/privileges/privileges.factor +++ b/basis/io/windows/nt/privileges/privileges.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types alien.syntax arrays continuations destructors generic io.mmap io.ports io.windows io.windows.files -kernel libc math math.bitfields namespaces quotations sequences windows +kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors io.windows.privileges ; IN: io.windows.nt.privileges diff --git a/basis/io/windows/nt/sockets/sockets.factor b/basis/io/windows/nt/sockets/sockets.factor index a31c41942f..41c5e88f5f 100755 --- a/basis/io/windows/nt/sockets/sockets.factor +++ b/basis/io/windows/nt/sockets/sockets.factor @@ -1,9 +1,8 @@ USING: alien alien.accessors alien.c-types byte-arrays continuations destructors io.ports io.timeouts io.sockets io.sockets io namespaces io.streams.duplex io.windows -io.windows.sockets -io.windows.nt.backend windows.winsock kernel libc math sequences -threads classes.tuple.lib system combinators accessors ; +io.windows.sockets io.windows.nt.backend windows.winsock kernel +libc math sequences threads system combinators accessors ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) @@ -28,71 +27,89 @@ M: winnt WSASocket-flags ( -- DWORD ) ] keep *void* ; TUPLE: ConnectEx-args port - s* name* namelen* lpSendBuffer* dwSendDataLength* - lpdwBytesSent* lpOverlapped* ptr* ; + s name namelen lpSendBuffer dwSendDataLength + lpdwBytesSent lpOverlapped ptr ; : wait-for-socket ( args -- n ) - [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; + [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline : ( sockaddr size -- ConnectEx ) ConnectEx-args new - swap >>namelen* - swap >>name* - f >>lpSendBuffer* - 0 >>dwSendDataLength* - f >>lpdwBytesSent* - (make-overlapped) >>lpOverlapped* ; + swap >>namelen + swap >>name + f >>lpSendBuffer + 0 >>dwSendDataLength + f >>lpdwBytesSent + (make-overlapped) >>lpOverlapped ; inline : call-ConnectEx ( ConnectEx -- ) - ConnectEx-args >tuple*< + { + [ s>> ] + [ name>> ] + [ namelen>> ] + [ lpSendBuffer>> ] + [ dwSendDataLength>> ] + [ lpdwBytesSent>> ] + [ lpOverlapped>> ] + [ ptr>> ] + } cleave "int" { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } "stdcall" alien-indirect drop - winsock-error-string [ throw ] when* ; + winsock-error-string [ throw ] when* ; inline M: object establish-connection ( client-out remote -- ) make-sockaddr/size swap >>port - dup port>> handle>> handle>> >>s* - dup s*>> get-ConnectEx-ptr >>ptr* + dup port>> handle>> handle>> >>s + dup s>> get-ConnectEx-ptr >>ptr dup call-ConnectEx wait-for-socket drop ; TUPLE: AcceptEx-args port - sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* - dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; + sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength + dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; : init-accept-buffer ( addr AcceptEx -- ) swap sockaddr-type heap-size 16 + - [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi - dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer* - drop ; + [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi + dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer + drop ; inline : ( server addr -- AcceptEx ) AcceptEx-args new 2dup init-accept-buffer - swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket* - over handle>> handle>> >>sListenSocket* + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket + over handle>> handle>> >>sListenSocket swap >>port - 0 >>dwReceiveDataLength* - f >>lpdwBytesReceived* - (make-overlapped) >>lpOverlapped* ; + 0 >>dwReceiveDataLength + f >>lpdwBytesReceived + (make-overlapped) >>lpOverlapped ; inline : call-AcceptEx ( AcceptEx -- ) - AcceptEx-args >tuple*< AcceptEx drop - winsock-error-string [ throw ] when* ; + { + [ sListenSocket>> ] + [ sAcceptSocket>> ] + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + [ lpdwBytesReceived>> ] + [ lpOverlapped>> ] + } cleave AcceptEx drop + winsock-error-string [ throw ] when* ; inline : extract-remote-address ( AcceptEx -- sockaddr ) { - [ lpOutputBuffer*>> ] - [ dwReceiveDataLength*>> ] - [ dwLocalAddressLength*>> ] - [ dwRemoteAddressLength*>> ] + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] } cleave f 0 f - [ 0 GetAcceptExSockaddrs ] keep *void* ; + [ 0 GetAcceptExSockaddrs ] keep *void* ; inline M: object (accept) ( server addr -- handle sockaddr ) [ @@ -100,39 +117,49 @@ M: object (accept) ( server addr -- handle sockaddr ) { [ call-AcceptEx ] [ wait-for-socket drop ] - [ sAcceptSocket*>> ] + [ sAcceptSocket>> ] [ extract-remote-address ] } cleave ] with-destructors ; TUPLE: WSARecvFrom-args port - s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd* - lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; + s lpBuffers dwBufferCount lpNumberOfBytesRecvd + lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; : make-receive-buffer ( -- WSABUF ) "WSABUF" malloc-object &free default-buffer-size get over set-WSABUF-len - default-buffer-size get malloc &free over set-WSABUF-buf ; + default-buffer-size get malloc &free over set-WSABUF-buf ; inline : ( datagram -- WSARecvFrom ) WSARecvFrom-args new swap >>port - dup port>> handle>> handle>> >>s* + dup port>> handle>> handle>> >>s dup port>> addr>> sockaddr-type heap-size - [ malloc &free >>lpFrom* ] - [ malloc-int &free >>lpFromLen* ] bi - make-receive-buffer >>lpBuffers* - 1 >>dwBufferCount* - 0 malloc-int &free >>lpFlags* - 0 malloc-int &free >>lpNumberOfBytesRecvd* - (make-overlapped) >>lpOverlapped* ; + [ malloc &free >>lpFrom ] + [ malloc-int &free >>lpFromLen ] bi + make-receive-buffer >>lpBuffers + 1 >>dwBufferCount + 0 malloc-int &free >>lpFlags + 0 malloc-int &free >>lpNumberOfBytesRecvd + (make-overlapped) >>lpOverlapped ; inline : call-WSARecvFrom ( WSARecvFrom -- ) - WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesRecvd>> ] + [ lpFlags>> ] + [ lpFrom>> ] + [ lpFromLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSARecvFrom socket-error* ; inline : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) - [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] - [ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ; + [ lpBuffers>> WSABUF-buf swap memory>byte-array ] + [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline M: winnt (receive) ( datagram -- packet addrspec ) [ @@ -144,31 +171,41 @@ M: winnt (receive) ( datagram -- packet addrspec ) ] with-destructors ; TUPLE: WSASendTo-args port - s* lpBuffers* dwBufferCount* lpNumberOfBytesSent* - dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ; + s lpBuffers dwBufferCount lpNumberOfBytesSent + dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; : make-send-buffer ( packet -- WSABUF ) "WSABUF" malloc-object &free [ >r malloc-byte-array &free r> set-WSABUF-buf ] [ >r length r> set-WSABUF-len ] [ nip ] - 2tri ; + 2tri ; inline : ( packet addrspec datagram -- WSASendTo ) WSASendTo-args new swap >>port - dup port>> handle>> handle>> >>s* + dup port>> handle>> handle>> >>s swap make-sockaddr/size >r malloc-byte-array &free - r> [ >>lpTo* ] [ >>iToLen* ] bi* - swap make-send-buffer >>lpBuffers* - 1 >>dwBufferCount* - 0 >>dwFlags* - 0 >>lpNumberOfBytesSent* - (make-overlapped) >>lpOverlapped* ; + r> [ >>lpTo ] [ >>iToLen ] bi* + swap make-send-buffer >>lpBuffers + 1 >>dwBufferCount + 0 >>dwFlags + 0 >>lpNumberOfBytesSent + (make-overlapped) >>lpOverlapped ; inline : call-WSASendTo ( WSASendTo -- ) - WSASendTo-args >tuple*< WSASendTo socket-error* ; + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesSent>> ] + [ dwFlags>> ] + [ lpTo>> ] + [ iToLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSASendTo socket-error* ; inline M: winnt (send) ( packet addrspec datagram -- ) [ diff --git a/basis/io/windows/windows.factor b/basis/io/windows/windows.factor index a290821163..6f6c29fc55 100755 --- a/basis/io/windows/windows.factor +++ b/basis/io/windows/windows.factor @@ -5,7 +5,7 @@ io.buffers io.files io.ports io.sockets io.binary io.sockets io.timeouts windows.errors strings kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting -continuations math.bitfields system accessors ; +continuations math.bitwise system accessors ; IN: io.windows : set-inherit ( handle ? -- ) diff --git a/extra/cpu/8080/authors.txt b/basis/json/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/cpu/8080/authors.txt rename to basis/json/authors.txt diff --git a/extra/cpu/8080/emulator/authors.txt b/basis/json/reader/authors.txt similarity index 100% rename from extra/cpu/8080/emulator/authors.txt rename to basis/json/reader/authors.txt diff --git a/extra/json/reader/reader-docs.factor b/basis/json/reader/reader-docs.factor similarity index 100% rename from extra/json/reader/reader-docs.factor rename to basis/json/reader/reader-docs.factor diff --git a/extra/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor similarity index 91% rename from extra/json/reader/reader-tests.factor rename to basis/json/reader/reader-tests.factor index 4b7bd56f01..995ae0e0b8 100644 --- a/extra/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -11,9 +11,9 @@ IN: json.reader.tests { 102.0 } [ "102.0" json> ] unit-test { 102.5 } [ "102.5" json> ] unit-test { 102.5 } [ "102.50" json> ] unit-test -{ -10250 } [ "-102.5e2" json> ] unit-test -{ -10250 } [ "-102.5E+2" json> ] unit-test -{ 10.25 } [ "1025e-2" json> ] unit-test +{ -10250.0 } [ "-102.5e2" json> ] unit-test +{ -10250.0 } [ "-102.5E+2" json> ] unit-test +{ 10+1/4 } [ "1025e-2" json> ] unit-test { 0.125 } [ "0.125" json> ] unit-test { -0.125 } [ "-0.125" json> ] unit-test diff --git a/extra/json/reader/reader.factor b/basis/json/reader/reader.factor similarity index 100% rename from extra/json/reader/reader.factor rename to basis/json/reader/reader.factor diff --git a/extra/json/reader/summary.txt b/basis/json/reader/summary.txt similarity index 100% rename from extra/json/reader/summary.txt rename to basis/json/reader/summary.txt diff --git a/extra/json/summary.txt b/basis/json/summary.txt similarity index 100% rename from extra/json/summary.txt rename to basis/json/summary.txt diff --git a/extra/json/authors.txt b/basis/json/writer/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/json/authors.txt rename to basis/json/writer/authors.txt diff --git a/extra/json/writer/summary.txt b/basis/json/writer/summary.txt similarity index 100% rename from extra/json/writer/summary.txt rename to basis/json/writer/summary.txt diff --git a/extra/json/writer/writer-docs.factor b/basis/json/writer/writer-docs.factor similarity index 100% rename from extra/json/writer/writer-docs.factor rename to basis/json/writer/writer-docs.factor diff --git a/extra/json/writer/writer.factor b/basis/json/writer/writer.factor similarity index 100% rename from extra/json/writer/writer.factor rename to basis/json/writer/writer.factor diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 2fa0b6cc71..6f9ae3c883 100755 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -1,6 +1,5 @@ USING: sequences kernel math locals math.order math.ranges -accessors combinators.lib arrays namespaces combinators -combinators.short-circuit ; +accessors arrays namespaces combinators combinators.short-circuit ; IN: lcs > literal ; stack get pop >quotation end (expand-macros) ; : expand-macro? ( word -- quot ? ) - dup [ "macro" word-prop ] [ +transform-quot+ word-prop ] bi or dup [ - swap [ stack-effect in>> length ] [ +transform-n+ word-prop ] bi or + dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [ + swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or stack get length <= ] [ 2drop f f ] if ; diff --git a/extra/json/reader/authors.txt b/basis/match/authors.txt similarity index 100% rename from extra/json/reader/authors.txt rename to basis/match/authors.txt diff --git a/extra/match/match-docs.factor b/basis/match/match-docs.factor similarity index 100% rename from extra/match/match-docs.factor rename to basis/match/match-docs.factor diff --git a/extra/match/match-tests.factor b/basis/match/match-tests.factor similarity index 100% rename from extra/match/match-tests.factor rename to basis/match/match-tests.factor diff --git a/extra/match/match.factor b/basis/match/match.factor similarity index 100% rename from extra/match/match.factor rename to basis/match/match.factor diff --git a/extra/match/summary.txt b/basis/match/summary.txt similarity index 100% rename from extra/match/summary.txt rename to basis/match/summary.txt diff --git a/extra/match/tags.txt b/basis/match/tags.txt similarity index 100% rename from extra/match/tags.txt rename to basis/match/tags.txt diff --git a/basis/math/bitfields/bitfields-tests.factor b/basis/math/bitfields/bitfields-tests.factor deleted file mode 100755 index 8864b64532..0000000000 --- a/basis/math/bitfields/bitfields-tests.factor +++ /dev/null @@ -1,27 +0,0 @@ -USING: accessors math math.bitfields tools.test kernel words ; -IN: math.bitfields.tests - -[ 0 ] [ { } bitfield ] unit-test -[ 256 ] [ 1 { 8 } bitfield ] unit-test -[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test -[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test -[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test - -: a 1 ; inline -: b 2 ; inline - -: foo ( -- flags ) { a b } flags ; - -[ 3 ] [ foo ] unit-test -[ 3 ] [ { a b } flags ] unit-test -\ foo must-infer - -[ 0 ] [ { } bitfield-quot call ] unit-test - -[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test - -[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test - -[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test - -[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test diff --git a/basis/math/bitfields/bitfields.factor b/basis/math/bitfields/bitfields.factor deleted file mode 100644 index 6e859eb205..0000000000 --- a/basis/math/bitfields/bitfields.factor +++ /dev/null @@ -1,37 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences words -namespaces stack-checker.transforms ; -IN: math.bitfields - -GENERIC: (bitfield) ( value accum shift -- newaccum ) - -M: integer (bitfield) ( value accum shift -- newaccum ) - swapd shift bitor ; - -M: pair (bitfield) ( value accum pair -- newaccum ) - first2 >r dup word? [ swapd execute ] when r> shift bitor ; - -: bitfield ( values... bitspec -- n ) - 0 [ (bitfield) ] reduce ; - -: flags ( values -- n ) - 0 [ dup word? [ execute ] when bitor ] reduce ; - -GENERIC: (bitfield-quot) ( spec -- quot ) - -M: integer (bitfield-quot) ( spec -- quot ) - [ swapd shift bitor ] curry ; - -M: pair (bitfield-quot) ( spec -- quot ) - first2 over word? [ >r swapd execute r> ] [ ] ? - [ shift bitor ] append 2curry ; - -: bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] prefix concat ; - -\ bitfield [ bitfield-quot ] 1 define-transform - -\ flags [ - [ 0 , [ , \ bitor , ] each ] [ ] make -] 1 define-transform diff --git a/basis/math/bitfields/summary.txt b/basis/math/bitfields/summary.txt deleted file mode 100644 index d622f818fd..0000000000 --- a/basis/math/bitfields/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Domain-specific language for constructing integers diff --git a/unmaintained/graphics/viewer/authors.txt b/basis/math/bitwise/authors.txt old mode 100755 new mode 100644 similarity index 50% rename from unmaintained/graphics/viewer/authors.txt rename to basis/math/bitwise/authors.txt index 7c1b2f2279..f372b574ae --- a/unmaintained/graphics/viewer/authors.txt +++ b/basis/math/bitwise/authors.txt @@ -1 +1,2 @@ +Slava Pestov Doug Coleman diff --git a/basis/math/bitfields/bitfields-docs.factor b/basis/math/bitwise/bitwise-docs.factor similarity index 75% rename from basis/math/bitfields/bitfields-docs.factor rename to basis/math/bitwise/bitwise-docs.factor index f9d16d2b6c..247523369b 100644 --- a/basis/math/bitfields/bitfields-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax math ; -IN: math.bitfields +IN: math.bitwise ARTICLE: "math-bitfields" "Constructing bit fields" "Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:" @@ -35,3 +35,16 @@ HELP: bitfield " } ;" } } ; + +HELP: bits +{ $values { "m" integer } { "n" integer } { "m'" integer } } +{ $description "Keep only n bits from the integer m." } +{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; + +HELP: bitroll +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } +{ $description "Roll n by s bits to the left, wrapping around after w bits." } +{ $examples + { $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } +} ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor new file mode 100755 index 0000000000..8b13cb23b3 --- /dev/null +++ b/basis/math/bitwise/bitwise-tests.factor @@ -0,0 +1,29 @@ +USING: accessors math math.bitwise tools.test kernel words ; +IN: math.bitwise.tests + +[ 0 ] [ 1 0 0 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 1 1 bitroll ] unit-test +[ 1 ] [ 1 0 2 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 20 2 bitroll ] unit-test +[ 1 ] [ 1 8 8 bitroll ] unit-test +[ 1 ] [ 1 -8 8 bitroll ] unit-test +[ 1 ] [ 1 -32 8 bitroll ] unit-test +[ 128 ] [ 1 -1 8 bitroll ] unit-test +[ 8 ] [ 1 3 32 bitroll ] unit-test + +[ 0 ] [ { } bitfield ] unit-test +[ 256 ] [ 1 { 8 } bitfield ] unit-test +[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test +[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test +[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo ( -- flags ) { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +\ foo must-infer diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor new file mode 100644 index 0000000000..60c585c779 --- /dev/null +++ b/basis/math/bitwise/bitwise.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math math.functions sequences +sequences.private words namespaces macros hints +combinators fry ; +IN: math.bitwise + +! utilities +: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline +: set-bit ( x n -- y ) 2^ bitor ; inline +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline +: unmask ( x n -- ? ) bitnot bitand ; inline +: unmask? ( x n -- ? ) unmask 0 > ; inline +: mask ( x n -- ? ) bitand ; inline +: mask? ( x n -- ? ) mask 0 > ; inline +: wrap ( m n -- m' ) 1- bitand ; inline +: bits ( m n -- m' ) 2^ wrap ; inline +: mask-bit ( m n -- m' ) 1- 2^ mask ; inline + +: shift-mod ( n s w -- n ) + >r shift r> 2^ wrap ; inline + +: bitroll ( x s w -- y ) + [ wrap ] keep + [ shift-mod ] + [ [ - ] keep shift-mod ] 3bi bitor ; inline + +: bitroll-32 ( n s -- n' ) 32 bitroll ; + +HINTS: bitroll-32 bignum fixnum ; + +: bitroll-64 ( n s -- n' ) 64 bitroll ; + +HINTS: bitroll-64 bignum fixnum ; + +! 32-bit arithmetic +: w+ ( int int -- int ) + 32 bits ; inline +: w- ( int int -- int ) - 32 bits ; inline +: w* ( int int -- int ) * 32 bits ; inline + +! flags +MACRO: flags ( values -- ) + [ 0 ] [ [ execute bitor ] curry compose ] reduce ; + +! bitfield +r swapd execute r> ] [ ] ? + [ shift bitor ] append 2curry ; + +PRIVATE> + +MACRO: bitfield ( bitspec -- ) + [ 0 ] [ (bitfield-quot) compose ] reduce ; + +! bit-count +> + +GENERIC: (bit-count) ( x -- n ) + +M: fixnum (bit-count) + { + [ byte-bit-count ] + [ -8 shift byte-bit-count ] + [ -16 shift byte-bit-count ] + [ -24 shift byte-bit-count ] + } cleave + + + ; + +M: bignum (bit-count) + dup 0 = [ drop 0 ] [ + [ byte-bit-count ] [ -8 shift (bit-count) ] bi + + ] if ; + +PRIVATE> + +: bit-count ( x -- n ) + dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline diff --git a/basis/math/bitwise/summary.txt b/basis/math/bitwise/summary.txt new file mode 100644 index 0000000000..23f73db76c --- /dev/null +++ b/basis/math/bitwise/summary.txt @@ -0,0 +1 @@ +Bitwise arithmetic utilities diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index d723d55cb3..bed3a655b1 100755 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -2,18 +2,24 @@ USING: help.markup help.syntax math math.private math.functions math.complex.private ; IN: math.complex +ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers" +"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:" +{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" } +"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:" +{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" } +"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ; + ARTICLE: "complex-numbers" "Complex numbers" { $subsection complex } "Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "syntax-complex-numbers" } "." $nl -"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." -$nl "Complex numbers can be taken apart:" { $subsection real-part } { $subsection imaginary-part } { $subsection >rect } "Complex numbers can be constructed from real numbers:" { $subsection rect> } +{ $subsection "complex-numbers-zero" } { $see-also "syntax-complex-numbers" } ; HELP: complex { $class-description "The class of complex numbers with non-zero imaginary part." } ; diff --git a/basis/math/complex/complex-tests.factor b/basis/math/complex/complex-tests.factor index 063871ce5b..4b0481eca1 100755 --- a/basis/math/complex/complex-tests.factor +++ b/basis/math/complex/complex-tests.factor @@ -5,9 +5,14 @@ IN: math.complex.tests [ 1 C{ 0 1 } rect> ] must-fail [ C{ 0 1 } 1 rect> ] must-fail -[ f ] [ C{ 5 12.5 } 5 = ] unit-test -[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test -[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test +[ f ] [ C{ 5 12.5 } 5 = ] unit-test +[ f ] [ C{ 5 12.5 } 5 number= ] unit-test + +[ f ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test +[ t ] [ C{ 1.0 2.0 } C{ 1 2 } number= ] unit-test + +[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test +[ f ] [ C{ 1.0 2.3 } C{ 1 2 } number= ] unit-test [ C{ 2 5 } ] [ 2 5 rect> ] unit-test [ 2 5 ] [ C{ 2 5 } >rect ] unit-test @@ -30,7 +35,7 @@ IN: math.complex.tests [ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test [ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test -[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test +[ C{ 0.0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test [ -1 ] [ C{ 0 1 } C{ 0 1 } * ] unit-test [ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test [ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test @@ -45,18 +50,18 @@ IN: math.complex.tests [ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test -[ 5 ] [ C{ 3 4 } abs ] unit-test -[ 5 ] [ -5.0 abs ] unit-test +[ 5.0 ] [ C{ 3 4 } abs ] unit-test +[ 5.0 ] [ -5.0 abs ] unit-test ! Make sure arguments are sane -[ 0 ] [ 0 arg ] unit-test -[ 0 ] [ 1 arg ] unit-test +[ 0.0 ] [ 0 arg ] unit-test +[ 0.0 ] [ 1 arg ] unit-test [ t ] [ -1 arg 3.14 3.15 between? ] unit-test [ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test [ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test -[ 1 0 ] [ 1 >polar ] unit-test -[ 1 ] [ -1 >polar drop ] unit-test +[ 1.0 0.0 ] [ 1 >polar ] unit-test +[ 1.0 ] [ -1 >polar drop ] unit-test [ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test ! I broke something diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index cef0676d12..acc8a9d6d6 100755 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -17,6 +17,14 @@ M: complex absq >rect [ sq ] bi@ + ; [ [ real-part ] bi@ ] 2keep [ imaginary-part ] bi@ ; inline +M: complex hashcode* + nip >rect [ hashcode ] bi@ bitxor ; + +M: complex equal? + over complex? [ + 2>rect = [ = ] [ 2drop f ] if + ] [ 2drop f ] if ; + M: complex number= 2>rect number= [ number= ] [ 2drop f ] if ; @@ -36,12 +44,10 @@ M: complex abs absq >float fsqrt ; M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ; -M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ; - IN: syntax : C{ \ } [ first2 rect> ] parse-literal ; parsing M: complex pprint-delims drop \ C{ \ } ; - M: complex >pprint-sequence >rect 2array ; +M: complex pprint* pprint-object ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index c023258105..bbfd8f41be 100755 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -106,7 +106,7 @@ HELP: (rect>) HELP: rect> { $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } ; +{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ; HELP: >rect { $values { "z" number } { "x" real } { "y" real } } diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index f2d26e330d..d5bdac761f 100755 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -12,10 +12,11 @@ IN: math.functions.tests [ 0.25 ] [ 2.0 -2.0 fpow ] unit-test [ 4.0 ] [ 16 sqrt ] unit-test -[ C{ 0 4.0 } ] [ -16 sqrt ] unit-test +[ 2.0 ] [ 4.0 0.5 ^ ] unit-test +[ C{ 0.0 4.0 } ] [ -16 sqrt ] unit-test -[ 4.0 ] [ 2 2 ^ ] unit-test -[ 0.25 ] [ 2 -2 ^ ] unit-test +[ 4 ] [ 2 2 ^ ] unit-test +[ 1/4 ] [ 2 -2 ^ ] unit-test [ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test [ t ] [ e pi i* ^ real-part -1.0 = ] unit-test [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test @@ -27,6 +28,8 @@ IN: math.functions.tests [ 0 ] [ 0 3.0 ^ ] unit-test [ 0 ] [ 0 3 ^ ] unit-test +[ 0.0 ] [ 1 log ] unit-test + [ 1.0 ] [ 0 cosh ] unit-test [ 0.0 ] [ 1 acosh ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 4d71b25174..8516292e9d 100755 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -7,7 +7,7 @@ IN: math.functions ) ( x y -- z ) - dup zero? [ drop ] [ ] if ; inline + dup 0 = [ drop ] [ ] if ; inline PRIVATE> @@ -24,29 +24,57 @@ M: real sqrt >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; : each-bit ( n quot: ( ? -- ) -- ) - over 0 number= pick -1 number= or [ + over 0 = pick -1 = or [ 2drop ] [ 2dup >r >r >r odd? r> call r> 2/ r> each-bit ] if ; inline recursive -GENERIC: (^) ( x y -- z ) foldable - : ^n ( z w -- z^w ) 1 swap [ [ dupd * ] when >r sq r> ] each-bit nip ; inline -M: integer (^) - dup 0 < [ neg ^n recip ] [ ^n ] if ; +: integer^ ( x y -- z ) + dup 0 > [ ^n ] [ neg ^n recip ] if ; inline + +: >rect ( z -- x y ) + [ real-part ] [ imaginary-part ] bi ; inline + +: >float-rect ( z -- x y ) + >rect [ >float ] bi@ ; inline + +: >polar ( z -- abs arg ) + >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; + inline + +: cis ( arg -- z ) dup fcos swap fsin rect> ; inline + +: polar> ( abs arg -- z ) cis * ; inline + +: ^mag ( w abs arg -- magnitude ) + >r >r >float-rect swap r> swap fpow r> rot * fexp /f ; + inline + +: ^theta ( w abs arg -- theta ) + >r >r >float-rect r> flog * swap r> * + ; inline + +: ^complex ( x y -- z ) + swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline + +: real^? ( x y -- ? ) + 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline + +: 0^ ( x -- z ) + dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline : ^ ( x y -- z ) - over zero? [ - dup zero? - [ 2drop 0.0 0.0 / ] [ 0 < [ drop 1.0 0.0 / ] when ] if - ] [ - (^) - ] if ; inline + { + { [ over zero? ] [ nip 0^ ] } + { [ dup integer? ] [ integer^ ] } + { [ 2dup real^? ] [ fpow ] } + [ ^complex ] + } cond ; : (^mod) ( n x y -- z ) 1 swap [ @@ -98,42 +126,27 @@ M: real absq sq ; [ ~abs ] } cond ; -: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline - : conjugate ( z -- z* ) >rect neg rect> ; inline -: >float-rect ( z -- x y ) - >rect swap >float swap >float ; inline - : arg ( z -- arg ) >float-rect swap fatan2 ; inline -: >polar ( z -- abs arg ) - >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ; - inline - -: cis ( arg -- z ) dup fcos swap fsin rect> ; inline - -: polar> ( abs arg -- z ) cis * ; inline - -: ^mag ( w abs arg -- magnitude ) - >r >r >float-rect swap r> swap fpow r> rot * fexp /f ; - inline - -: ^theta ( w abs arg -- theta ) - >r >r >float-rect r> flog * swap r> * + ; inline - -M: number (^) - swap >polar 3dup ^theta >r ^mag r> polar> ; - : [-1,1]? ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline : >=1? ( x -- ? ) dup complex? [ drop f ] [ 1 >= ] if ; inline -: exp ( x -- y ) >rect swap fexp swap polar> ; inline +GENERIC: exp ( x -- y ) -: log ( x -- y ) >polar swap flog swap rect> ; inline +M: real exp fexp ; + +M: complex exp >rect swap fexp swap polar> ; + +GENERIC: log ( x -- y ) + +M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; + +M: complex log >polar swap flog swap rect> ; : cos ( x -- y ) dup complex? [ diff --git a/basis/math/geometry/rect/rect-docs.factor b/basis/math/geometry/rect/rect-docs.factor index 3e21dfe307..a892940363 100644 --- a/basis/math/geometry/rect/rect-docs.factor +++ b/basis/math/geometry/rect/rect-docs.factor @@ -17,11 +17,6 @@ HELP: ( loc dim -- rect ) { } related-words -HELP: set-rect-dim ( dim rect -- ) -{ $values { "dim" "a pair of integers" } { "rect" rect } } -{ $description "Modifies the dimensions of a rectangle." } -{ $side-effects "rect" } ; - HELP: rect-bounds { $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } } { $description "Outputs the location and dimensions of a rectangle." } ; diff --git a/basis/math/geometry/rect/rect.factor b/basis/math/geometry/rect/rect.factor index 7f0bb94092..dd634f4a3b 100644 --- a/basis/math/geometry/rect/rect.factor +++ b/basis/math/geometry/rect/rect.factor @@ -7,6 +7,9 @@ IN: math.geometry.rect TUPLE: rect loc dim ; +GENERIC: rect-loc ( obj -- loc ) +GENERIC: rect-dim ( obj -- dim ) + : init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ; : ( loc dim -- rect ) rect boa ; @@ -17,6 +20,10 @@ M: array rect-loc ; M: array rect-dim drop { 0 0 } ; +M: rect rect-loc loc>> ; + +M: rect rect-dim dim>> ; + : rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; : rect-extent ( rect -- loc ext ) rect-bounds over v+ ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 806b0961ca..7d8d496737 100755 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -60,11 +60,11 @@ IN: math.intervals.tests ] unit-test [ t ] [ - 1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] = + 1 2 [a,b] -0.5 0.5 [a,b] interval* -1.0 1.0 [a,b] = ] unit-test [ t ] [ - 1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] = + 1 2 [a,b] -0.5 0.5 (a,b] interval* -1.0 1.0 (a,b] = ] unit-test [ t ] [ @@ -131,7 +131,7 @@ IN: math.intervals.tests "math.ratios.private" vocab [ [ t ] [ - -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) = + -1 1 (a,b) 0.5 1 (a,b) interval/ -2.0 2.0 (a,b) = ] unit-test ] when diff --git a/extra/math/points/points.factor b/basis/math/points/points.factor similarity index 100% rename from extra/math/points/points.factor rename to basis/math/points/points.factor diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor index 28801fa2e9..c01e7377b2 100755 --- a/basis/math/ratios/ratios-tests.factor +++ b/basis/math/ratios/ratios-tests.factor @@ -81,8 +81,8 @@ unit-test [ -1/2 ] [ 1/2 1- ] unit-test [ 3/2 ] [ 1/2 1+ ] unit-test -[ 1 ] [ 0.5 1/2 + ] unit-test -[ 1 ] [ 1/2 0.5 + ] unit-test +[ 1.0 ] [ 0.5 1/2 + ] unit-test +[ 1.0 ] [ 1/2 0.5 + ] unit-test [ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test [ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 6569ee9540..5dde4fbb99 100755 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -30,6 +30,14 @@ M: integer / 2dup gcd nip tuck /i >r /i r> fraction> ] if ; +M: ratio hashcode* + nip >fraction [ hashcode ] bi@ bitxor ; + +M: ratio equal? + over ratio? [ + 2>fraction = [ = ] [ 2drop f ] if + ] [ 2drop f ] if ; + M: ratio number= 2>fraction number= [ number= ] [ 2drop f ] if ; diff --git a/basis/mirrors/mirrors-docs.factor b/basis/mirrors/mirrors-docs.factor index 55896a9811..d6a8d51fbe 100755 --- a/basis/mirrors/mirrors-docs.factor +++ b/basis/mirrors/mirrors-docs.factor @@ -30,7 +30,7 @@ HELP: ( object -- mirror ) "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." - "{ { \"delegate\" f } { \"center\" { 100 50 } } { \"radius\" 15 } }" + "{ { \"center\" { 100 50 } } { \"radius\" 15 } }" } } ; diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index 2eda136ae5..aad033600a 100755 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -6,16 +6,16 @@ TUPLE: foo bar baz ; C: foo -[ 3 ] [ 1 2 assoc-size ] unit-test +[ 2 ] [ 1 2 assoc-size ] unit-test -[ { "delegate" "bar" "baz" } ] [ 1 2 keys ] unit-test +[ { "bar" "baz" } ] [ 1 2 keys ] unit-test [ 1 t ] [ "bar" 1 2 at* ] unit-test [ f f ] [ "hi" 1 2 at* ] unit-test [ 3 ] [ - 3 "baz" 1 2 [ set-at ] keep foo-baz + 3 "baz" 1 2 [ set-at ] keep baz>> ] unit-test [ 3 "hi" 1 2 set-at ] must-fail diff --git a/basis/models/compose/compose-tests.factor b/basis/models/compose/compose-tests.factor index 25ba001d5d..16a5ab339c 100755 --- a/basis/models/compose/compose-tests.factor +++ b/basis/models/compose/compose-tests.factor @@ -1,6 +1,6 @@ -IN: models.compose.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.compose ; +tools.test models.compose accessors ; +IN: models.compose.tests ! Test compose [ ] [ @@ -11,14 +11,14 @@ tools.test models.compose ; [ ] [ "c" get activate-model ] unit-test -[ { 1 2 } ] [ "c" get model-value ] unit-test +[ { 1 2 } ] [ "c" get value>> ] unit-test [ ] [ 3 "b" get set-model ] unit-test -[ { 1 3 } ] [ "c" get model-value ] unit-test +[ { 1 3 } ] [ "c" get value>> ] unit-test [ ] [ { 4 5 } "c" get set-model ] unit-test -[ { 4 5 } ] [ "c" get model-value ] unit-test +[ { 4 5 } ] [ "c" get value>> ] unit-test [ ] [ "c" get deactivate-model ] unit-test diff --git a/basis/models/compose/compose.factor b/basis/models/compose/compose.factor index 015986fad0..a2c3385248 100755 --- a/basis/models/compose/compose.factor +++ b/basis/models/compose/compose.factor @@ -18,12 +18,12 @@ TUPLE: compose < model ; M: compose model-changed nip - [ [ model-value ] composed-value ] keep set-model ; + [ [ value>> ] composed-value ] keep set-model ; M: compose model-activated dup model-changed ; M: compose update-model - dup model-value swap [ set-model ] set-composed-value ; + dup value>> swap [ set-model ] set-composed-value ; M: compose range-value [ range-value ] composed-value ; diff --git a/basis/models/filter/filter-tests.factor b/basis/models/filter/filter-tests.factor index bdf3273fae..ad43568e06 100755 --- a/basis/models/filter/filter-tests.factor +++ b/basis/models/filter/filter-tests.factor @@ -1,18 +1,18 @@ -IN: models.filter.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.filter ; +tools.test models.filter accessors ; +IN: models.filter.tests ! Test multiple filters 3 "x" set "x" get [ 2 * ] dup "z" set [ 1+ ] "y" set [ ] [ "y" get activate-model ] unit-test -[ t ] [ "z" get "x" get model-connections memq? ] unit-test -[ 7 ] [ "y" get model-value ] unit-test +[ t ] [ "z" get "x" get connections>> memq? ] unit-test +[ 7 ] [ "y" get value>> ] unit-test [ ] [ 4 "x" get set-model ] unit-test -[ 9 ] [ "y" get model-value ] unit-test +[ 9 ] [ "y" get value>> ] unit-test [ ] [ "y" get deactivate-model ] unit-test -[ f ] [ "z" get "x" get model-connections memq? ] unit-test +[ f ] [ "z" get "x" get connections>> memq? ] unit-test 3 "x" set "x" get [ sq ] "y" set @@ -20,5 +20,5 @@ tools.test models.filter ; 4 "x" get set-model "y" get activate-model -[ 16 ] [ "y" get model-value ] unit-test +[ 16 ] [ "y" get value>> ] unit-test "y" get deactivate-model diff --git a/basis/models/history/history-tests.factor b/basis/models/history/history-tests.factor index 40d1176667..c89dd5c5b3 100755 --- a/basis/models/history/history-tests.factor +++ b/basis/models/history/history-tests.factor @@ -1,37 +1,37 @@ -IN: models.history.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.history ; +tools.test models.history accessors ; +IN: models.history.tests f "history" set "history" get add-history -[ t ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test "history" get add-history 3 "history" get set-model -[ t ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test "history" get add-history 4 "history" get set-model -[ f ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test "history" get go-back -[ 3 ] [ "history" get model-value ] unit-test +[ 3 ] [ "history" get value>> ] unit-test -[ t ] [ "history" get history-back empty? ] unit-test -[ f ] [ "history" get history-forward empty? ] unit-test +[ t ] [ "history" get back>> empty? ] unit-test +[ f ] [ "history" get forward>> empty? ] unit-test "history" get go-forward -[ 4 ] [ "history" get model-value ] unit-test +[ 4 ] [ "history" get value>> ] unit-test -[ f ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test diff --git a/basis/models/mapping/mapping-tests.factor b/basis/models/mapping/mapping-tests.factor index 43c1883bb1..6e1a1dc8d0 100755 --- a/basis/models/mapping/mapping-tests.factor +++ b/basis/models/mapping/mapping-tests.factor @@ -1,6 +1,6 @@ -IN: models.mapping.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.mapping ; +tools.test models.mapping accessors ; +IN: models.mapping.tests ! Test mapping [ ] [ @@ -14,7 +14,7 @@ tools.test models.mapping ; [ ] [ "m" get activate-model ] unit-test [ H{ { "one" 1 } { "two" 2 } } ] [ - "m" get model-value + "m" get value>> ] unit-test [ ] [ @@ -23,12 +23,12 @@ tools.test models.mapping ; ] unit-test [ H{ { "one" 3 } { "two" 4 } } ] [ - "m" get model-value + "m" get value>> ] unit-test [ H{ { "one" 5 } { "two" 4 } } ] [ - 5 "one" "m" get mapping-assoc at set-model - "m" get model-value + 5 "one" "m" get assoc>> at set-model + "m" get value>> ] unit-test [ ] [ "m" get deactivate-model ] unit-test diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index ee1bb542f0..fe10d3ab8e 100755 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -1,13 +1,12 @@ -IN: models.tests USING: arrays generic kernel math models models.compose -namespaces sequences assocs -tools.test ; +namespaces sequences assocs accessors tools.test ; +IN: models.tests TUPLE: model-tester hit? ; : model-tester new ; -M: model-tester model-changed nip t swap set-model-tester-hit? ; +M: model-tester model-changed nip t >>hit? drop ; [ T{ model-tester f t } ] [ @@ -20,7 +19,7 @@ M: model-tester model-changed nip t swap set-model-tester-hit? ; "model-a" get "model-b" get 2array "model-c" set "model-c" get activate-model -[ { 3 4 } ] [ "model-c" get model-value ] unit-test +[ { 3 4 } ] [ "model-c" get value>> ] unit-test "model-c" get deactivate-model T{ model-tester f f } "tester" set @@ -30,5 +29,5 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get add-connection 6 "model-a" get set-model "tester" get - "model-c" get model-value + "model-c" get value>> ] unit-test diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 0c0eb5e9dd..4782571d4a 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -9,14 +9,30 @@ HELP: <" { $syntax "<\" text \">" } { $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ; -{ POSTPONE: <" POSTPONE: STRING: } related-words +HELP: /* +{ $syntax "/* comment */" } +{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." } +{ $example "USING: multiline ;" + "/* I think that I shall never see" + " A poem lovely as a tree. */" + "" +} ; -HELP: parse-here -{ $values { "str" "a string" } } -{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: STRING: } "." } ; +{ POSTPONE: <" POSTPONE: STRING: } related-words HELP: parse-multiline-string { $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } } -{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: <" } ". The end-text is the delimiter for the end." } ; +{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." } +{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ; -{ parse-here parse-multiline-string } related-words +ARTICLE: "multiline" "Multiline" +"Multiline strings:" +{ $subsection POSTPONE: STRING: } +{ $subsection POSTPONE: <" } +"Multiline comments:" +{ $subsection POSTPONE: /* } +"Writing new multiline parsing words:" +{ $subsection parse-multiline-string } +; + +ABOUT: "multiline" diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 67bcc55a06..561af504c6 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -4,6 +4,7 @@ USING: namespaces parser lexer kernel sequences words quotations math accessors ; IN: multiline +> ; @@ -13,6 +14,7 @@ IN: multiline [ drop lexer get next-line ] [ % "\n" % (parse-here) ] if ] [ ";" unexpected-eof ] if* ; +PRIVATE> : parse-here ( -- str ) [ (parse-here) ] "" make but-last @@ -22,6 +24,7 @@ IN: multiline CREATE-WORD parse-here 1quotation define-inline ; parsing +> [ 2dup start @@ -30,6 +33,7 @@ IN: multiline lexer get next-line swap (parse-multiline-string) ] if* ] [ nip unexpected-eof ] if* ; +PRIVATE> : parse-multiline-string ( end-text -- str ) [ diff --git a/basis/nmake/nmake-tests.factor b/basis/nmake/nmake-tests.factor new file mode 100644 index 0000000000..a6b1afb297 --- /dev/null +++ b/basis/nmake/nmake-tests.factor @@ -0,0 +1,8 @@ +IN: nmake.tests +USING: nmake kernel tools.test ; + +[ ] [ [ ] { } nmake ] unit-test + +[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test + +[ [ ] [ call ] curry { { } } nmake ] must-infer diff --git a/basis/nmake/nmake.factor b/basis/nmake/nmake.factor new file mode 100644 index 0000000000..80c3ce3411 --- /dev/null +++ b/basis/nmake/nmake.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sequences math.parser kernel macros +generalizations locals ; +IN: nmake + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, ( obj n -- ) get-building-seq push ; +: n% ( seq n -- ) get-building-seq push-all ; +: n# ( num n -- ) >r number>string r> n% ; + +: 0, ( obj -- ) 0 n, ; +: 0% ( seq -- ) 0 n% ; +: 0# ( num -- ) 0 n# ; +: 1, ( obj -- ) 1 n, ; +: 1% ( seq -- ) 1 n% ; +: 1# ( num -- ) 1 n# ; +: 2, ( obj -- ) 2 n, ; +: 2% ( seq -- ) 2 n% ; +: 2# ( num -- ) 2 n# ; +: 3, ( obj -- ) 3 n, ; +: 3% ( seq -- ) 3 n% ; +: 3# ( num -- ) 3 n# ; +: 4, ( obj -- ) 4 n, ; +: 4% ( seq -- ) 4 n% ; +: 4# ( num -- ) 4 n# ; + +MACRO: finish-nmake ( exemplars -- ) + length [ firstn ] curry ; + +:: nmake ( quot exemplars -- ) + [ + exemplars + [ 0 swap new-resizable ] map + building-seq set + + quot call + + building-seq get + exemplars [ [ like ] 2map ] [ finish-nmake ] bi + ] with-scope ; inline diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index e951ad8858..f1dc21f993 100755 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -2,7 +2,7 @@ ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax combinators kernel system namespaces -assocs parser lexer sequences words quotations math.bitfields ; +assocs parser lexer sequences words quotations math.bitwise ; IN: openssl.libssl diff --git a/basis/openssl/test/errors.txt b/basis/openssl/test/errors.txt deleted file mode 100644 index e965047ad7..0000000000 --- a/basis/openssl/test/errors.txt +++ /dev/null @@ -1 +0,0 @@ -Hello diff --git a/extra/json/writer/authors.txt b/basis/peg/ebnf/authors.txt similarity index 100% rename from extra/json/writer/authors.txt rename to basis/peg/ebnf/authors.txt diff --git a/extra/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor similarity index 99% rename from extra/peg/ebnf/ebnf-tests.factor rename to basis/peg/ebnf/ebnf-tests.factor index 47f19920c7..a6d3cf0b21 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -105,11 +105,11 @@ IN: peg.ebnf.tests ] unit-test { "foo" } [ - "foo" 'non-terminal' parse ebnf-non-terminal-symbol + "foo" 'non-terminal' parse symbol>> ] unit-test { "foo" } [ - "foo]" 'non-terminal' parse ebnf-non-terminal-symbol + "foo]" 'non-terminal' parse symbol>> ] unit-test { V{ "a" "b" } } [ diff --git a/extra/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor similarity index 96% rename from extra/peg/ebnf/ebnf.factor rename to basis/peg/ebnf/ebnf.factor index 6e9d78e649..7083262c49 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.units words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories multiline combinators.lib + peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker io prettyprint combinators parser ; diff --git a/extra/peg/ebnf/summary.txt b/basis/peg/ebnf/summary.txt similarity index 100% rename from extra/peg/ebnf/summary.txt rename to basis/peg/ebnf/summary.txt diff --git a/extra/peg/ebnf/tags.txt b/basis/peg/ebnf/tags.txt similarity index 100% rename from extra/peg/ebnf/tags.txt rename to basis/peg/ebnf/tags.txt diff --git a/extra/peg/peg.factor b/basis/peg/peg.factor similarity index 98% rename from extra/peg/peg.factor rename to basis/peg/peg.factor index 0cf0382ee2..9ef1ac658e 100755 --- a/extra/peg/peg.factor +++ b/basis/peg/peg.factor @@ -513,18 +513,11 @@ TUPLE: action-parser p1 quot ; M: action-parser (compile) ( peg -- quot ) [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; -: left-trim-slice ( string -- string ) - #! Return a new string without any leading whitespace - #! from the original string. - dup empty? [ - dup first blank? [ rest-slice left-trim-slice ] when - ] unless ; - TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) p1>> compile-parser 1quotation '[ - input-slice left-trim-slice input-from pos set @ + input-slice [ blank? ] trim-left-slice input-from pos set @ ] ; TUPLE: delay-parser quot ; diff --git a/extra/match/authors.txt b/basis/peg/search/authors.txt similarity index 100% rename from extra/match/authors.txt rename to basis/peg/search/authors.txt diff --git a/extra/peg/search/search-docs.factor b/basis/peg/search/search-docs.factor similarity index 100% rename from extra/peg/search/search-docs.factor rename to basis/peg/search/search-docs.factor diff --git a/extra/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor similarity index 100% rename from extra/peg/search/search-tests.factor rename to basis/peg/search/search-tests.factor diff --git a/extra/peg/search/search.factor b/basis/peg/search/search.factor similarity index 100% rename from extra/peg/search/search.factor rename to basis/peg/search/search.factor diff --git a/extra/peg/search/summary.txt b/basis/peg/search/summary.txt similarity index 100% rename from extra/peg/search/summary.txt rename to basis/peg/search/summary.txt diff --git a/extra/peg/search/tags.txt b/basis/peg/search/tags.txt similarity index 100% rename from extra/peg/search/tags.txt rename to basis/peg/search/tags.txt diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index ae60aba50e..2e2be264bb 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -51,5 +51,5 @@ M: persistent-hash clone ; : PH{ \ } [ >persistent-hash ] parse-literal ; parsing M: persistent-hash pprint-delims drop \ PH{ \ } ; - M: persistent-hash >pprint-sequence >alist ; +M: persistent-hash pprint* pprint-object ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index 7fb14a4541..f231043274 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: math math.bit-count arrays kernel accessors locals sequences -sequences.private sequences.lib +USING: math math.bitwise arrays kernel accessors locals sequences +sequences.private persistent.sequences persistent.hashtables.config persistent.hashtables.nodes ; diff --git a/basis/persistent/hashtables/nodes/collision/collision.factor b/basis/persistent/hashtables/nodes/collision/collision.factor index b74a2ed45d..83003e5c47 100644 --- a/basis/persistent/hashtables/nodes/collision/collision.factor +++ b/basis/persistent/hashtables/nodes/collision/collision.factor @@ -1,6 +1,6 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: kernel accessors math arrays fry sequences sequences.lib +USING: kernel accessors math arrays fry sequences locals persistent.sequences persistent.hashtables.config persistent.hashtables.nodes diff --git a/basis/persistent/hashtables/nodes/full/full.factor b/basis/persistent/hashtables/nodes/full/full.factor index e0fcc1a0ab..5c60c91dca 100644 --- a/basis/persistent/hashtables/nodes/full/full.factor +++ b/basis/persistent/hashtables/nodes/full/full.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: math accessors kernel arrays sequences sequences.private -locals sequences.lib +locals persistent.sequences persistent.hashtables.config persistent.hashtables.nodes ; diff --git a/basis/persistent/hashtables/nodes/nodes.factor b/basis/persistent/hashtables/nodes/nodes.factor index 6201e68c6a..d681cd57fa 100644 --- a/basis/persistent/hashtables/nodes/nodes.factor +++ b/basis/persistent/hashtables/nodes/nodes.factor @@ -1,6 +1,6 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: math arrays kernel sequences sequences.lib +USING: math arrays kernel sequences accessors locals persistent.hashtables.config ; IN: persistent.hashtables.nodes diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index a636d31f48..92b3f82a54 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -182,7 +182,7 @@ M: persistent-vector equal? : PV{ \ } [ >persistent-vector ] parse-literal ; parsing M: persistent-vector pprint-delims drop \ PV{ \ } ; - M: persistent-vector >pprint-sequence ; +M: persistent-vector pprint* pprint-object ; INSTANCE: persistent-vector immutable-sequence diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor index c6eff28d08..cc4f5cedb5 100755 --- a/basis/prettyprint/backend/backend-docs.factor +++ b/basis/prettyprint/backend/backend-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io kernel prettyprint +USING: help.markup help.syntax io kernel prettyprint.config prettyprint.sections words strings ; IN: prettyprint.backend @@ -24,7 +24,7 @@ HELP: unparse-ch HELP: do-string-limit { $values { "str" string } { "trimmed" "a possibly trimmed string" } } -{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ; +{ $description "If " { $link string-limit? } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ; HELP: pprint-string { $values { "obj" object } { "str" string } { "prefix" string } { "suffix" string } } diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 8e5e932666..34ab1a2fcc 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -80,7 +80,7 @@ M: f pprint* drop \ f pprint-word ; dup ch>ascii-escape [ "\\" % ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) - string-limit get [ + string-limit? get [ dup length margin get > [ margin get 3 - head "..." append ] when @@ -129,6 +129,30 @@ M: pathname pprint* ] if ] if ; inline +: tuple>assoc ( tuple -- assoc ) + [ class all-slots ] [ tuple-slots ] bi zip + [ [ initial>> ] dip = not ] assoc-filter + [ [ name>> ] dip ] assoc-map ; + +: pprint-slot-value ( name value -- ) + ] bi* + \ } pprint-word block> ; + +M: tuple pprint* + boa-tuples? get [ call-next-method ] [ + [ + assoc [ pprint-slot-value ] assoc-each + block> + \ } pprint-word + block> + ] check-recursion + ] if ; + : do-length-limit ( seq -- trimmed n/f ) length-limit get dup [ over length over [-] @@ -163,10 +187,12 @@ M: byte-vector >pprint-sequence ; M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; -M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped>> 1array ; M: callstack >pprint-sequence callstack>array ; +M: tuple >pprint-sequence + [ class f 2array ] [ tuple-slots ] bi append ; + GENERIC: pprint-narrow? ( obj -- ? ) M: object pprint-narrow? drop f ; @@ -186,6 +212,8 @@ M: tuple pprint-narrow? drop t ; ] check-recursion ; M: object pprint* pprint-object ; +M: vector pprint* pprint-object ; +M: hashtable pprint* pprint-object ; M: curry pprint* dup quot>> callable? [ pprint-object ] [ diff --git a/basis/prettyprint/config/config-docs.factor b/basis/prettyprint/config/config-docs.factor index 1a2fd69949..dda565d5c9 100644 --- a/basis/prettyprint/config/config-docs.factor +++ b/basis/prettyprint/config/config-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io kernel prettyprint +USING: help.markup help.syntax io kernel prettyprint.sections words ; IN: prettyprint.config @@ -19,5 +19,9 @@ HELP: length-limit HELP: line-limit { $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ; -HELP: string-limit +HELP: string-limit? { $var-description "Toggles whether printed strings are truncated to the margin." } ; + +HELP: boa-tuples? +{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." } +{ $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ; diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index 6a649bc5a6..d986791f94 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: prettyprint.config USING: arrays generic assocs io kernel math namespaces sequences strings io.styles vectors words continuations ; +IN: prettyprint.config ! Configuration SYMBOL: tab-size @@ -11,10 +11,8 @@ SYMBOL: margin SYMBOL: nesting-limit SYMBOL: length-limit SYMBOL: line-limit -SYMBOL: string-limit +SYMBOL: string-limit? +SYMBOL: boa-tuples? -global [ - 4 tab-size set - 64 margin set - string-limit off -] bind +4 tab-size set-global +64 margin set-global diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index f7f0f7ee44..44cf5f724f 100755 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -26,7 +26,8 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables" { $subsection nesting-limit } { $subsection length-limit } { $subsection line-limit } -{ $subsection string-limit } +{ $subsection string-limit? } +{ $subsection boa-tuples? } "Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables." { $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope." @@ -86,7 +87,7 @@ $nl { $subsection "prettyprint-section-protocol" } ; ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" -"Unless a more specialized method exists for the input class, the " { $link pprint* } " word outputs an object in a standard format, ultimately calling two generic words:" +"Most custom data types have a literal syntax which resembles a sequence. An easy way to define such a syntax is to add a method to the " { $link pprint* } " generic word which calls " { $link pprint-object } ", and then to provide methods on two other generic words:" { $subsection pprint-delims } { $subsection >pprint-sequence } "For example, consider the following data type, together with a parsing word for creating literals:" @@ -104,10 +105,11 @@ ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" { $code "RECT[ 100 * 200 ]" } "Without further effort, the literal does not print in the same way:" { $unchecked-example "RECT[ 100 * 200 ] ." "T{ rect f 100 200 }" } -"However, we can define two methods easily enough:" +"However, we can define three methods easily enough:" { $code "M: rect pprint-delims drop \\ RECT[ \\ ] ;" "M: rect >pprint-sequence dup rect-w \\ * rot rect-h 3array ;" + "M: rect pprint* pprint-object ;" } "Now, it will be printed in a custom way:" { $unchecked-example "RECT[ 100 * 200 ] ." "RECT[ 100 * 200 ]" } ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 63a44d85d4..c52ab18027 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -71,7 +71,8 @@ IN: prettyprint { line-limit 1 } { length-limit 15 } { nesting-limit 2 } - { string-limit t } + { string-limit? t } + { boa-tuples? t } } clone [ pprint ] bind ; : unparse-short ( obj -- str ) diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 01e79abff2..0a730190c2 100755 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -3,7 +3,7 @@ ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges random circular math.bitfields.lib +accessors math.ranges random circular math.bitwise combinators ; IN: random.mersenne-twister diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index d85df3e0be..eed4bf2e13 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -1,4 +1,4 @@ -USING: random sequences tools.test ; +USING: random sequences tools.test kernel ; IN: random.tests [ 4 ] [ 4 random-bytes length ] unit-test @@ -6,3 +6,6 @@ IN: random.tests [ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test [ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test + +[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test +[ V{ } [ delete-random drop ] keep length ] must-fail diff --git a/basis/random/random.factor b/basis/random/random.factor index 74b7a78723..d37e2fc2b7 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -43,6 +43,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; ] keep nth ] if ; +: delete-random ( seq -- elt ) + [ length random ] keep [ nth ] 2keep delete-nth ; + : random-bits ( n -- r ) 2^ random ; : with-random ( tuple quot -- ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 5df4b80614..fa98c7a947 100755 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces io io.timeouts kernel logging io.sockets -sequences combinators sequences.lib splitting assocs strings +USING: arrays namespaces io io.timeouts kernel logging +io.sockets sequences combinators splitting assocs strings math.parser random system calendar io.encodings.ascii summary calendar.format accessors sets hashtables ; IN: smtp @@ -112,7 +112,7 @@ ERROR: smtp-transaction-failed < smtp-error ; } cond ; : multiline? ( response -- boolean ) - ?fourth CHAR: - = ; + 3 swap ?nth CHAR: - = ; : process-multiline ( multiline -- response ) >r readln r> 2dup " " append head? [ @@ -184,21 +184,3 @@ PRIVATE> : send-email ( email -- ) [ email>headers ] keep (send-email) ; - -! Dirk's old AUTH CRAM-MD5 code. I don't know anything about -! CRAM MD5, and the old code didn't work properly either, so here -! it is in case anyone wants to fix it later. -! -! check-response used to have this clause: -! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } -! -! and the rest of the code was as follows: -! : (cram-md5-auth) ( -- response ) -! swap challenge get -! string>md5-hmac hex-string -! " " prepend append -! >base64 ; -! -! : cram-md5-auth ( key login -- ) -! "AUTH CRAM-MD5\r\n" get-ok -! (cram-md5-auth) "\r\n" append get-ok ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c01236fba9..80e888a3e9 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -47,7 +47,7 @@ IN: stack-checker.known-words : infer-shuffle ( shuffle -- ) [ in>> length consume-d ] keep ! inputs shuffle - [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies + [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies [ nip ] [ swap zip ] 2bi ! inputs copies mapping #shuffle, ; @@ -108,7 +108,7 @@ M: object infer-call* : infer- ( -- ) \ - peek-d literal value>> size>> { tuple } + peek-d literal value>> size>> 1+ { tuple } apply-word/effect ; : infer-(throw) ( -- ) @@ -173,15 +173,13 @@ do-primitive alien-invoke alien-indirect alien-callback { call execute dispatch load-locals get-local drop-locals } [ t "no-compile" set-word-prop ] each -SYMBOL: +primitive+ - : non-inline-word ( word -- ) dup called-dependency depends-on { { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } { [ dup "special" word-prop ] [ infer-special ] } - { [ dup +primitive+ word-prop ] [ infer-primitive ] } - { [ dup +transform-quot+ word-prop ] [ apply-transform ] } + { [ dup "primitive" word-prop ] [ infer-primitive ] } + { [ dup "transform-quot" word-prop ] [ apply-transform ] } { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } @@ -190,7 +188,7 @@ SYMBOL: +primitive+ } cond ; : define-primitive ( word inputs outputs -- ) - [ 2drop t +primitive+ set-word-prop ] + [ 2drop t "primitive" set-word-prop ] [ drop "input-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ] 3tri ; @@ -600,8 +598,6 @@ SYMBOL: +primitive+ \ (set-os-envs) { array } { } define-primitive -\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop - \ dll-valid? { object } { object } define-primitive \ modify-code-heap { array object } { } define-primitive diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index dc049ee1a4..9bf8ed62f0 100755 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -148,7 +148,7 @@ M: fixnum potential-hang dup [ potential-hang ] when ; TUPLE: funny-cons car cdr ; GENERIC: iterate ( obj -- ) -M: funny-cons iterate funny-cons-cdr iterate ; +M: funny-cons iterate cdr>> iterate ; M: f iterate drop ; M: real iterate drop ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 3d3db980e1..0d0de7f19b 100755 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -89,8 +89,11 @@ SYMBOL: meta-r SYMBOL: dependencies : depends-on ( word how -- ) - dependencies get dup - [ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ; + over primitive? [ 2drop ] [ + dependencies get dup [ + swap '[ , strongest-dependency ] change-at + ] [ 3drop ] if + ] if ; ! Generic words that the current quotation depends on SYMBOL: generic-dependencies diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 200b5d9c43..2773b8b4e4 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -8,9 +8,6 @@ stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors ; IN: stack-checker.transforms -SYMBOL: +transform-quot+ -SYMBOL: +transform-n+ - : give-up-transform ( word -- ) dup recursive-label [ call-recursive-word ] @@ -48,8 +45,8 @@ SYMBOL: +transform-n+ : apply-transform ( word -- ) [ inlined-dependency depends-on ] [ [ ] - [ +transform-quot+ word-prop ] - [ +transform-n+ word-prop ] + [ "transform-quot" word-prop ] + [ "transform-n" word-prop ] tri (apply-transform) ] bi ; @@ -64,8 +61,8 @@ SYMBOL: +transform-n+ ] bi ; : define-transform ( word quot n -- ) - [ drop +transform-quot+ set-word-prop ] - [ nip +transform-n+ set-word-prop ] + [ drop "transform-quot" set-word-prop ] + [ nip "transform-n" set-word-prop ] 3bi ; ! Combinators @@ -108,8 +105,11 @@ SYMBOL: +transform-n+ \ new [ dup tuple-class? [ dup inlined-dependency depends-on - dup all-slots rest-slice ! delegate slot - [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make + [ + [ all-slots [ initial>> literalize , ] each ] + [ literalize , ] bi + \ boa , + ] [ ] make ] [ drop f ] if ] 1 define-transform diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index ee5a5113bf..15c83bf73a 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences strings circular prettyprint debugger ascii sbufs fry summary -accessors sequences.lib ; +accessors ; IN: state-parser ! * Basic underlying words @@ -120,7 +120,7 @@ M: not-enough-characters summary ( obj -- str ) : take ( n -- string ) [ 1- ] [ ] bi [ - '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + '[ drop get-char [ next , push f ] [ t ] if* ] contains? drop ] keep get-char [ over push ] when* >string ; : pass-blank ( -- ) diff --git a/extra/syndication/authors.txt b/basis/syndication/authors.txt similarity index 100% rename from extra/syndication/authors.txt rename to basis/syndication/authors.txt diff --git a/extra/syndication/readme.txt b/basis/syndication/readme.txt similarity index 100% rename from extra/syndication/readme.txt rename to basis/syndication/readme.txt diff --git a/extra/syndication/summary.txt b/basis/syndication/summary.txt similarity index 100% rename from extra/syndication/summary.txt rename to basis/syndication/summary.txt diff --git a/extra/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor similarity index 90% rename from extra/syndication/syndication-tests.factor rename to basis/syndication/syndication-tests.factor index 73541e7908..eb2095203c 100755 --- a/extra/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -25,7 +25,7 @@ IN: syndication.tests f } } -} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test +} ] [ "resource:basis/syndication/test/rss1.xml" load-news-file ] unit-test [ T{ feed f @@ -42,4 +42,4 @@ IN: syndication.tests T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } -} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test +} ] [ "resource:basis/syndication/test/atom.xml" load-news-file ] unit-test diff --git a/extra/syndication/syndication.factor b/basis/syndication/syndication.factor similarity index 100% rename from extra/syndication/syndication.factor rename to basis/syndication/syndication.factor diff --git a/extra/syndication/tags.txt b/basis/syndication/tags.txt similarity index 100% rename from extra/syndication/tags.txt rename to basis/syndication/tags.txt diff --git a/extra/syndication/test/atom.xml b/basis/syndication/test/atom.xml similarity index 100% rename from extra/syndication/test/atom.xml rename to basis/syndication/test/atom.xml diff --git a/extra/syndication/test/rss1.xml b/basis/syndication/test/rss1.xml similarity index 100% rename from extra/syndication/test/rss1.xml rename to basis/syndication/test/rss1.xml diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index affb95c761..f0a3235e62 100755 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax words parser ; +USING: help.markup help.syntax words parser quotations strings +system sequences ; IN: tools.annotations ARTICLE: "tools.annotations" "Word annotations" @@ -20,6 +21,8 @@ HELP: watch { $values { "word" word } } { $description "Annotates a word definition to print the data stack on entry and exit." } ; +{ watch watch-vars reset } related-words + HELP: breakpoint { $values { "word" word } } { $description "Annotates a word definition to enter the single stepper when executed." } ; @@ -27,3 +30,36 @@ HELP: breakpoint HELP: breakpoint-if { $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; + +HELP: annotate-methods +{ $values + { "word" word } { "quot" quotation } } +{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ; + +HELP: entering +{ $values + { "str" string } } +{ $description "Prints a message and the inputs to the word before the word has been called." } ; + +HELP: leaving +{ $values + { "str" string } } +{ $description "Prints a message and the outputs from a word after a word has been called." } ; + +HELP: reset +{ $values + { "word" word } } +{ $description "Resets any annotations on a word." } +{ $notes "This word will remove a " { $link watch } "." } ; + +HELP: watch-vars +{ $values + { "word" word } { "vars" "a sequence of symbols" } } +{ $description "Annotates a word definition to print the " { $snippet "vars" } " upon entering the word. This word is useful for debugging." } ; + +HELP: word-inputs +{ $values + { "word" word } + { "seq" sequence } } +{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ; + diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 9171a480cf..3d007e566c 100755 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -79,7 +79,7 @@ M: quit-responder call-responder* [ add-quot-responder - "resource:extra/http/test" >>default + "resource:basis/http/test" >>default main-responder set test-httpd diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index eaa0342c25..7e37436654 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -85,8 +85,11 @@ IN: tools.deploy.shaker [ strip-dictionary? [ { + "cannot-infer" "coercer" + "combination" "compiled-effect" + "compiled-generic-uses" "compiled-uses" "constraints" "declared-effect" @@ -94,38 +97,51 @@ IN: tools.deploy.shaker "default-method" "default-output-classes" "derived-from" - "identities" + "engines" "if-intrinsics" "infer" "inferred-effect" + "inline" + "inlined-block" "input-classes" "interval" "intrinsics" + "lambda" "loc" + "local-reader" + "local-reader?" + "local-writer" + "local-writer?" + "local?" + "macro" "members" - "methods" + "memo-quot" "method-class" "method-generic" - "combination" - "cannot-infer" + "methods" "no-compile" "optimizer-hooks" - "output-classes" + "outputs" "participants" "predicate" "predicate-definition" "predicating" - "tuple-dispatch-generic" - "slots" + "reader" + "reading" + "recursive" + "shuffle" "slot-names" + "slots" + "special" "specializer" "step-into" "step-into?" - "superclass" - "reading" - "writing" + "transform-n" + "transform-quot" + "tuple-dispatch-generic" "type" - "engines" + "writer" + "writing" } % ] when @@ -211,6 +227,7 @@ IN: tools.deploy.shaker classes:update-map command-line:main-vocab-hook compiled-crossref + compiled-generic-crossref compiler.units:recompile-hook compiler.units:update-tuples-hook definitions:crossref @@ -229,13 +246,14 @@ IN: tools.deploy.shaker word } % - { } { "optimizer.math.partial" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % ] when strip-prettyprint? [ { prettyprint.config:margin - prettyprint.config:string-limit + prettyprint.config:string-limit? + prettyprint.config:boa-tuples? prettyprint.config:tab-size } % ] when diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 490c21a067..098e99719e 100755 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.1" } - { deploy-threads? t } - { deploy-compiler? t } - { deploy-math? t } { deploy-c-types? f } + { deploy-name "tools.deploy.test.1" } { deploy-io 2 } - { deploy-reflection 1 } - { deploy-ui? f } + { deploy-random? f } + { deploy-math? t } + { deploy-compiler? t } + { deploy-reflection 2 } { "stop-after-last-window?" t } + { deploy-threads? t } + { deploy-ui? f } { deploy-word-props? f } + { deploy-word-defs? f } } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index aeec8e94f7..c6f46eede6 100755 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-compiler? t } - { deploy-reflection 2 } + { deploy-io 2 } { deploy-ui? f } - { deploy-word-props? f } { deploy-threads? t } { deploy-c-types? f } - { deploy-random? f } - { "stop-after-last-window?" t } { deploy-name "tools.deploy.test.2" } - { deploy-io 2 } + { deploy-compiler? t } + { deploy-word-props? f } + { deploy-reflection 2 } { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index dde8291658..5f45b87e0d 100755 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.3" } - { deploy-threads? t } - { deploy-compiler? t } - { deploy-math? t } - { deploy-c-types? f } { deploy-io 3 } - { deploy-reflection 1 } { deploy-ui? f } - { "stop-after-last-window?" t } + { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.3" } + { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index 65ead56e2b..ea899e64c0 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } { deploy-io 2 } - { deploy-c-types? f } - { deploy-random? f } { deploy-ui? f } - { deploy-name "tools.deploy.test.4" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.4" } { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index bb4580b7ae..797116e09b 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } { deploy-io 3 } - { deploy-c-types? f } - { deploy-random? f } { deploy-ui? f } - { deploy-name "tools.deploy.test.5" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.5" } { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/scaffold/authors.txt b/basis/tools/scaffold/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/tools/scaffold/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor new file mode 100644 index 0000000000..e22e10f8c9 --- /dev/null +++ b/basis/tools/scaffold/scaffold-docs.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel strings words ; +IN: tools.scaffold + +HELP: developer-name +{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." } +{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ; + +HELP: help. +{ $values + { "word" word } } +{ $description "Prints out scaffold help markup for a given word." } ; + +HELP: scaffold-help +{ $values + { "vocab-root" "a vocabulary root string" } { "string" string } } +{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ; + +HELP: scaffold-undocumented +{ $values + { "string" string } } +{ $description "Prints scaffolding documenation for undocumented words in a vocabuary except for automatically generated class predicates." } ; + +{ scaffold-help scaffold-undocumented } related-words + +HELP: scaffold-vocab +{ $values + { "vocab-root" "a vocabulary root string" } { "string" string } } +{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ; + +HELP: using +{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ; + +ARTICLE: "tools.scaffold" "Scaffold tool" +"Scaffold setup:" +{ $subsection developer-name } +"Generate new vocabs:" +{ $subsection scaffold-vocab } +"Generate help scaffolding:" +{ $subsection scaffold-help } +{ $subsection scaffold-undocumented } +{ $subsection help. } +"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." +; + +ABOUT: "tools.scaffold" diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor new file mode 100644 index 0000000000..8bc9f93bd2 --- /dev/null +++ b/basis/tools/scaffold/scaffold.factor @@ -0,0 +1,258 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs io.files hashtables kernel namespaces sequences +vocabs.loader io combinators io.encodings.utf8 calendar accessors +math.parser io.streams.string ui.tools.operations quotations +strings arrays prettyprint words vocabs sorting sets +classes math alien ; +IN: tools.scaffold + +SYMBOL: developer-name +SYMBOL: using + +ERROR: not-a-vocab-root string ; +ERROR: vocab-name-contains-separator path ; +ERROR: vocab-name-contains-dot path ; +ERROR: no-vocab vocab ; + + . ; + +: scaffolding ( path -- ) + "Creating scaffolding for " write . ; + +: scaffold-path ( path string -- path ? ) + dupd [ file-name ] dip append append-path + dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ; + +: scaffold-copyright ( -- ) + "! Copyright (C) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write "." print + "! See http://factorcode.org/license.txt for BSD license." print ; + +: main-file-string ( vocab -- string ) + [ + scaffold-copyright + "USING: ;" print + "IN: " write print + ] with-string-writer ; + +: set-scaffold-main-file ( path vocab -- ) + main-file-string swap utf8 set-file-contents ; + +: scaffold-main ( path vocab -- ) + [ ".factor" scaffold-path ] dip + swap [ set-scaffold-main-file ] [ 2drop ] if ; + +: tests-file-string ( vocab -- string ) + [ + scaffold-copyright + "USING: tools.test " write dup write " ;" print + "IN: " write write ".tests" print + ] with-string-writer ; + +: set-scaffold-tests-file ( path vocab -- ) + tests-file-string swap utf8 set-file-contents ; + +: scaffold-tests ( path vocab -- ) + [ "-tests.factor" scaffold-path ] dip + swap [ set-scaffold-tests-file ] [ 2drop ] if ; + +: scaffold-authors ( path -- ) + "authors.txt" append-path dup exists? [ + not-scaffolding + ] [ + dup scaffolding + developer-name get swap utf8 set-file-contents + ] if ; + +: lookup-type ( string -- object/string ? ) + H{ + { "object" object } { "obj" object } + { "obj1" object } { "obj2" object } + { "obj3" object } { "obj4" object } + { "quot" quotation } { "quot1" quotation } + { "quot2" quotation } { "quot3" quotation } + { "quot'" quotation } + { "string" string } { "string1" string } + { "string2" string } { "string3" string } + { "str" string } + { "str1" string } { "str2" string } { "str3" string } + { "hash" hashtable } + { "hashtable" hashtable } + { "?" "a boolean" } + { "ch" "a character" } + { "word" word } + { "array" array } + { "duration" duration } + { "path" "a pathname string" } + { "vocab" "a vocabulary specifier" } + { "vocab-root" "a vocabulary root string" } + { "c-ptr" c-ptr } + { "seq" sequence } { "seq1" sequence } { "seq2" sequence } + { "seq3" sequence } { "seq4" sequence } + { "seq1'" sequence } { "seq2'" sequence } + { "newseq" sequence } + { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc } + { "assoc3" assoc } { "newassoc" assoc } + { "alist" "an array of key/value pairs" } + { "keys" sequence } { "values" sequence } + { "class" class } + } at* ; + +: add-using ( object -- ) + vocabulary>> using get [ conjoin ] [ drop ] if* ; + +: ($values.) ( array -- ) + [ + " { " write + dup array? [ first ] when + dup lookup-type [ + [ unparse write bl ] + [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi* + ] [ + drop unparse write bl null pprint + null add-using + ] if + " }" write + ] each ; + +: $values. ( word -- ) + "declared-effect" word-prop [ + [ in>> ] [ out>> ] bi + 2dup [ empty? ] bi@ and [ + 2drop + ] [ + "{ $values" print + [ " " write ($values.) ] + [ [ nl " " write ($values.) ] unless-empty ] bi* + " }" write nl + ] if + ] when* ; + +: $description. ( word -- ) + drop + "{ $description \"\" } ;" print ; + +: help-header. ( word -- ) + "HELP: " write name>> print ; + +: (help.) ( word -- ) + [ help-header. ] [ $values. ] [ $description. ] tri ; + +: interesting-words ( vocab -- array ) + words + [ [ "help" word-prop ] [ predicate? ] bi or not ] filter + natural-sort ; + +: interesting-words. ( vocab -- ) + interesting-words [ (help.) nl ] each ; + +: help-file-string ( str1 -- str2 ) + [ + { + [ "IN: " write print nl ] + [ interesting-words. ] + [ "ARTICLE: " write unparse dup write bl print ";" print nl ] + [ "ABOUT: " write unparse print ] + } cleave + ] with-string-writer ; + +: write-using ( -- ) + "USING:" write + using get keys + { "help.markup" "help.syntax" } append natural-sort + [ bl write ] each + " ;" print ; + +: set-scaffold-help-file ( path vocab -- ) + swap utf8 [ + scaffold-copyright help-file-string write-using write + ] with-output-stream ; + +: check-scaffold ( vocab-root string -- vocab-root string ) + [ check-root ] [ check-vocab-name ] bi* ; + +: vocab>scaffold-path ( vocab-root string -- path ) + path-separator first CHAR: . associate substitute + append-path ; + +: prepare-scaffold ( vocab-root string -- string path ) + check-scaffold [ vocab>scaffold-path ] keep ; + +: with-scaffold ( quot -- ) + [ H{ } clone using ] dip with-variable ; inline + +: check-vocab ( vocab -- vocab ) + dup find-vocab-root [ no-vocab ] unless ; +PRIVATE> + +: link-vocab ( vocab -- ) + check-vocab + "Edit documentation: " write + [ find-vocab-root ] keep + [ append-path ] keep "-docs.factor" append append-path + . ; + +: help. ( word -- ) + [ (help.) ] [ nl vocabulary>> link-vocab ] bi ; + +: scaffold-help ( vocab-root string -- ) + [ + check-vocab + prepare-scaffold + [ "-docs.factor" scaffold-path ] dip + swap [ set-scaffold-help-file ] [ 2drop ] if + ] with-scaffold ; + +: scaffold-undocumented ( string -- ) + [ interesting-words. ] [ link-vocab ] bi ; + +: scaffold-vocab ( vocab-root string -- ) + prepare-scaffold + { + [ drop scaffold-directory ] + [ scaffold-main ] + [ scaffold-tests ] + [ drop scaffold-authors ] + [ nip require ] + } 2cleave ; + +SYMBOL: examples-flag + +: example ( -- ) + { + "{ $example \"\" \"USING: prettyprint ;\"" + " \"\"" + " \"\"" + "}" + } [ examples-flag get [ " " write ] when print ] each ; + +: examples ( n -- ) + t \ examples-flag [ + "{ $examples " print + [ example ] times + "}" print + ] with-variable ; diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor index 12b2e41d36..ed2e486ecc 100755 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/tools/vocabs/monitor/monitor.factor @@ -9,8 +9,8 @@ IN: tools.vocabs.monitor TR: convert-separators "/\\" ".." ; : vocab-dir>vocab-name ( path -- vocab ) - left-trim-separators - right-trim-separators + trim-left-separators + trim-right-separators convert-separators ; : path>vocab-name ( path -- vocab ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 08eb3d7c32..cc49d283b4 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -190,7 +190,7 @@ M: vocab-link summary vocab-summary ; vocab-dir "tags.txt" append-path ; : vocab-tags ( vocab -- tags ) - dup vocab-tags-path vocab-file-contents ; + dup vocab-tags-path vocab-file-contents harvest ; : set-vocab-tags ( tags vocab -- ) dup vocab-tags-path set-vocab-file-contents ; @@ -202,7 +202,7 @@ M: vocab-link summary vocab-summary ; vocab-dir "authors.txt" append-path ; : vocab-authors ( vocab -- authors ) - dup vocab-authors-path vocab-file-contents ; + dup vocab-authors-path vocab-file-contents harvest ; : set-vocab-authors ( authors vocab -- ) dup vocab-authors-path set-vocab-file-contents ; diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 4c288b1c9e..7aa49b880f 100755 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -1,4 +1,5 @@ -USING: tuple-arrays sequences tools.test namespaces kernel math accessors ; +USING: tuple-arrays sequences tools.test namespaces kernel +math accessors ; IN: tuple-arrays.tests SYMBOL: mat @@ -6,14 +7,14 @@ TUPLE: foo bar ; C: foo [ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test -[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test +[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ T{ foo f 3 } t ] -[ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test +[ mat get [ bar>> 2 + ] map [ first ] keep tuple-array? ] unit-test [ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test -[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test +[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test TUPLE: baz { bing integer } bong ; [ 0 ] [ 1 baz first bing>> ] unit-test diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 8d176b9c63..1a05d23aa0 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -24,10 +24,10 @@ TUPLE: pasteboard handle ; C: pasteboard M: pasteboard clipboard-contents - pasteboard-handle pasteboard-string ; + handle>> pasteboard-string ; M: pasteboard set-clipboard-contents - pasteboard-handle set-pasteboard-string ; + handle>> set-pasteboard-string ; : init-clipboard ( -- ) NSPasteboard -> generalPasteboard @@ -44,29 +44,29 @@ M: pasteboard set-clipboard-contents dup install-window-delegate over -> release - ] keep set-world-handle ; + ] keep (>>handle) ; M: cocoa-ui-backend set-title ( string world -- ) - world-handle handle-window swap -> setTitle: ; + handle>> window>> swap -> setTitle: ; : enter-fullscreen ( world -- ) - world-handle handle-view + handle>> view>> NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; : exit-fullscreen ( world -- ) - world-handle handle-view f -> exitFullScreenModeWithOptions: ; + handle>> view>> f -> exitFullScreenModeWithOptions: ; M: cocoa-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; M: cocoa-ui-backend fullscreen* ( world -- ? ) - world-handle handle-view -> isInFullScreenMode zero? not ; + handle>> view>> -> isInFullScreenMode zero? not ; : auto-position ( world -- ) dup window-loc>> { 0 0 } = [ - world-handle handle-window -> center + handle>> window>> -> center ] [ drop ] if ; @@ -74,29 +74,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) M: cocoa-ui-backend (open-window) ( world -- ) dup gadget-window dup auto-position - world-handle handle-window f -> makeKeyAndOrderFront: ; + handle>> window>> f -> makeKeyAndOrderFront: ; M: cocoa-ui-backend (close-window) ( handle -- ) - handle-window -> release ; + window>> -> release ; M: cocoa-ui-backend close-window ( gadget -- ) find-world [ - world-handle [ - handle-window f -> performClose: + handle>> [ + window>> f -> performClose: ] when* ] when* ; M: cocoa-ui-backend raise-window* ( world -- ) - world-handle [ - handle-window dup f -> orderFront: -> makeKeyWindow + handle>> [ + window>> dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: ] when* ; M: cocoa-ui-backend select-gl-context ( handle -- ) - handle-view -> openGLContext -> makeCurrentContext ; + view>> -> openGLContext -> makeCurrentContext ; M: cocoa-ui-backend flush-gl-context ( handle -- ) - handle-view -> openGLContext -> flushBuffer ; + view>> -> openGLContext -> flushBuffer ; M: cocoa-ui-backend beep ( -- ) NSBeep ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 7bda548a26..d2dfe56ed4 100755 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -184,7 +184,7 @@ M: freetype-renderer string-height ( open-font string -- h ) : draw-char ( open-font sprites char loc -- ) GL_MODELVIEW [ 0 0 glTranslated - char-sprite sprite-dlist glCallList + char-sprite dlist>> glCallList ] do-matrix ; : char-widths ( open-font string -- widths ) diff --git a/basis/ui/gadgets/borders/borders.factor b/basis/ui/gadgets/borders/borders.factor index da21c06a1b..4609562af4 100644 --- a/basis/ui/gadgets/borders/borders.factor +++ b/basis/ui/gadgets/borders/borders.factor @@ -41,7 +41,7 @@ M: border pref-dim* M: border layout* dup border-child-rect swap gadget-child - over loc>> over set-rect-loc + over loc>> >>loc swap dim>> swap (>>dim) ; M: border focusable-child* diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 6c5d757dd4..bdd9ebaf13 100755 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -1,6 +1,7 @@ -IN: ui.gadgets.buttons.tests USING: ui.commands ui.gadgets.buttons ui.gadgets.labels -ui.gadgets tools.test namespaces sequences kernel models ; +ui.gadgets tools.test namespaces sequences kernel models +accessors ; +IN: ui.gadgets.buttons.tests TUPLE: foo-gadget ; @@ -15,7 +16,7 @@ TUPLE: foo-gadget ; T{ foo-gadget } "t" set -[ 2 ] [ "t" get gadget-children length ] unit-test +[ 2 ] [ "t" get children>> length ] unit-test [ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test [ ] [ @@ -34,7 +35,7 @@ T{ foo-gadget } "t" set \ must-infer [ 0 ] [ - "religion" get gadget-child radio-control-value + "religion" get gadget-child value>> ] unit-test [ 2 ] [ diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index b5e8e8a1e1..e04e385a23 100755 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -67,9 +67,12 @@ M: button-paint draw-interior M: button-paint draw-boundary button-paint draw-boundary ; +: align-left ( button -- button ) + { 0 1/2 } >>align ; inline + : roll-button-theme ( button -- button ) f black dup f >>boundary - { 0 1/2 } >>align ; inline + align-left ; inline : ( label quot -- button )