steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2008-09-07 01:29:25 +02:00
parent f1bb2cca20 0589e061e1
commit 3fdf30571f
847 changed files with 4184 additions and 2360 deletions
basis
alarms
alien/structs
bit-arrays
bit-vectors
bootstrap/image
calendar
channels
checksums
cocoa
compiler
concurrency/distributed
cpu
ppc
architecture
assembler/backend
intrinsics
x86
csv
db
debugger
delegate
editors/gvim
farkup
float-arrays
Show More

8
basis/alarms/alarms-docs.factor
View File

@ -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 }

4
basis/alarms/alarms.factor
View File

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

76
basis/alien/structs/fields/fields.factor Normal file
View File

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

74
basis/alien/structs/structs-docs.factor
View File

@ -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."

52
basis/alien/structs/structs.factor
View File

@ -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 )
<slot-spec>
0 >>offset
swap >>name
swap expand-constants >>class
3dup name>> swap reader-word >>reader
3dup name>> swap writer-word >>writer
2nip ;
: define-struct-early ( name vocab fields -- fields )
-rot [ rot first2 make-field ] 2curry map ;
-rot [ rot first2 <field-spec> ] 2curry map ;
: compute-struct-align ( types -- n )
[ c-type-align ] map supremum ;
@ -94,7 +52,7 @@ M: struct-type stack-size
: define-struct ( name vocab fields -- )
pick >r
[ struct-offsets ] keep
[ [ class>> ] map compute-struct-align ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
r> [ swap define-field ] curry each ;

2
basis/bit-arrays/bit-arrays.factor
View File

@ -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 ;

2
basis/bit-vectors/bit-vectors.factor
View File

@ -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 ;

8
basis/bootstrap/image/image.factor
View File

@ -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 '

4
basis/calendar/backend/backend.factor
View File

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

447
basis/calendar/calendar-docs.factor
View File

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

4
basis/calendar/calendar-tests.factor
View File

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

66
basis/calendar/calendar.factor
View File

@ -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 <duration> ;
: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
: years ( x -- duration ) instant clone swap >>year ;
: months ( x -- duration ) instant clone swap >>month ;
: days ( x -- duration ) instant clone swap >>day ;
@ -125,14 +129,6 @@ MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
: minutes ( x -- duration ) instant clone swap >>minute ;
: seconds ( x -- duration ) instant clone swap >>second ;
: milliseconds ( x -- duration ) 1000 / seconds ;
ALIAS: year years
ALIAS: month months
ALIAS: day days
ALIAS: week weeks
ALIAS: hour hours
ALIAS: minute minutes
ALIAS: second seconds
ALIAS: millisecond milliseconds
GENERIC: leap-year? ( obj -- ? )
@ -244,7 +240,7 @@ M: duration time+
2drop <duration>
] if ;
: dt>years ( duration -- x )
: duration>years ( duration -- x )
#! Uses average month/year length since duration loses calendar
#! data
0 swap
@ -257,16 +253,16 @@ M: duration time+
[ second>> seconds-per-year / + ]
} cleave ;
M: duration <=> [ dt>years ] compare ;
M: duration <=> [ duration>years ] compare ;
: dt>months ( duration -- x ) dt>years months-per-year * ;
: 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: <zero> ( -- timestamp )
0 0 0 0 0 0 instant <timestamp> ;
: <zero> ( -- timestamp )
0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
MEMO: unix-1970 ( -- timestamp )
: unix-1970 ( -- timestamp )
1970 1 1 0 0 0 instant <timestamp> ;
: millis>timestamp ( n -- timestamp )
: millis>timestamp ( x -- timestamp )
>r unix-1970 r> milliseconds time+ ;
: timestamp>millis ( timestamp -- n )
@ -331,12 +327,9 @@ MEMO: unix-1970 ( -- timestamp )
unix-1970 millis milliseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
#! http://web.textfiles.com/computers/formulas.txt
@ -371,19 +364,21 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: day-of-year ( timestamp -- n )
>date< (day-of-year) ;
<PRIVATE
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp )
day-offset days time+ ;
PRIVATE>
: sunday ( timestamp -- timestamp ) 0 day-this-week ;
: 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 ;

12
basis/calendar/format/format-tests.factor
View File

@ -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

4
basis/calendar/unix/unix.factor
View File

@ -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 )

4
basis/calendar/windows/windows.factor
View File

@ -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 )

4
basis/channels/channels.factor
View File

@ -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 ;

10
basis/channels/remote/remote.factor
View File

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

0
basis/calendar/backend/authors.txt → basis/checksums/common/authors.txt Executable file → Normal file
View File

21
basis/checksums/common/common.factor Normal file
View File

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

1
basis/checksums/common/summary.txt Normal file
View File

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

11
basis/checksums/md5/md5.factor
View File

@ -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
<PRIVATE
SYMBOLS: a b c d old-a old-b old-c old-d ;

23
basis/checksums/sha1/sha1.factor
View File

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

19
basis/checksums/sha2/sha2.factor
View File

@ -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
<PRIVATE
@ -81,6 +83,8 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
: T1 ( W n -- T1 )
[ swap nth ] keep
K get nth +
@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: seq>byte-array ( n seq -- string )
[ swap [ >be % ] curry each ] B{ } make ;
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
>r >sbuf r> over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %
length 3 shift 8 rot [ >be ] [ >le ] if %
] "" make over push-all ;
: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each

16
basis/cocoa/cocoa-tests.factor
View File

@ -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

2
basis/cocoa/windows/windows.factor
View File

@ -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

2
basis/compiler/compiler-docs.factor
View File

@ -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"

4
basis/compiler/compiler.factor
View File

@ -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 ;

2
basis/compiler/generator/fixup/fixup.factor
View File

@ -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

2
basis/compiler/generator/registers/registers.factor
View File

@ -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

2
basis/compiler/tree/intrinsics/intrinsics.factor → basis/compiler/intrinsics/intrinsics.factor
View File

@ -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 ;

9
basis/compiler/tests/alien.factor Normal file → Executable file
View File

@ -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" }

4
basis/compiler/tests/optimizer.factor
View File

@ -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

4
basis/compiler/tests/stack-trace.factor
View File

@ -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 ;

4
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -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?

5
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -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 ;

30
basis/compiler/tree/dead-code/simple/simple.factor Normal file → Executable file
View File

@ -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 ;

2
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -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

8
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

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

113
basis/compiler/tree/finalization/finalization.factor
View File

@ -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>> \ <tuple-boa> eq? [
last-literal tuple-layout?
] [ drop f ] if ;
MEMO: (tuple-boa-expansion) ( n -- quot )
[
[ 2 + ] map <reversed>
[ '[ [ , set-slot ] keep ] % ] each
] [ ] make ;
: tuple-boa-expansion ( layout -- quot )
#! No memoization here since otherwise we'd hang on to
#! tuple layout objects.
size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
: expand-tuple-boa ( #call -- node )
last-literal tuple-boa-expansion ;
MEMO: <array>-expansion ( n -- quot )
[
[ swap (array) ] %
[ \ 2dup , , [ swap set-array-nth ] % ] each
\ nip ,
] [ ] make splice-quot ;
: expand-<array>? ( #call -- ? )
dup word>> \ <array> eq? [
first-literal dup integer?
[ 0 32 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<array> ( #call -- node )
first-literal <array>-expansion ;
: bytes>cells ( m -- n ) cell align cell /i ;
MEMO: <byte-array>-expansion ( n -- quot )
[
[ (byte-array) ] %
bytes>cells [ cell * ] map
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
] [ ] make splice-quot ;
: expand-<byte-array>? ( #call -- ? )
dup word>> \ <byte-array> eq? [
first-literal dup integer?
[ 0 128 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<byte-array> ( #call -- nodes )
first-literal <byte-array>-expansion ;
M: #call finalize*
{
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
{ [ dup expand-<array>? ] [ expand-<array> ] }
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
[ ]
} cond ;
M: node finalize* ;
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

2
basis/compiler/tree/normalization/normalization.factor
View File

@ -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 ;

36
basis/compiler/tree/propagation/info/info.factor
View File

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

16
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -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 ;

45
basis/compiler/tree/propagation/known-words/known-words.factor
View File

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

3
basis/compiler/tree/propagation/nodes/nodes.factor
View File

@ -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 -- )

20
basis/compiler/tree/propagation/propagation-tests.factor
View File

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

39
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -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 [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
recover ;
: fold-call ( #call word -- )
[ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
: predicate-output-infos ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
@ -95,30 +97,23 @@ M: #declare propagate-before
: output-value-infos ( #call word -- infos )
{
{ [ 2dup foldable-call? ] [ fold-call ] }
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] }
{ [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;
: do-inlining ( #call word -- ? )
{
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;
M: #call propagate-before
dup word>> 2dup do-inlining [ 2drop ] [
[ [ 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) ;

14
basis/compiler/tree/propagation/slots/slots.factor
View File

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

2
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

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

2
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -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

2
basis/concurrency/distributed/distributed.factor
View File

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

14
basis/cpu/ppc/architecture/architecture.factor
View File

@ -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 ;

2
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -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 , ;

111
basis/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -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> [
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" } }
} ;

2
basis/cpu/x86/64/64.factor
View File

@ -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 )

88
basis/cpu/x86/intrinsics/intrinsics.factor
View File

@ -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> [
ratio 3 cells [

0
extra/csv/authors.txt → basis/csv/authors.txt
View File

0
extra/csv/csv-docs.factor → basis/csv/csv-docs.factor
View File

0
extra/csv/csv-tests.factor → basis/csv/csv-tests.factor
View File

0
extra/csv/csv.factor → basis/csv/csv.factor
View File

0
extra/csv/summary.txt → basis/csv/summary.txt
View File

0
basis/editors/gvim/backend/authors.txt → basis/db/authors.txt Executable file → Normal file
View File

2
extra/db/db-tests.factor → basis/db/db-tests.factor
View File

@ -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

27
extra/db/db.factor → basis/db/db.factor
View File

@ -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: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
HOOK: <simple-statement> db ( string in out -- statement )
HOOK: <prepared-statement> db ( string in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
GENERIC: low-level-bind ( statement -- )

1
extra/db/errors/errors.factor → basis/db/errors/errors.factor
View File

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

2
extra/db/pools/pools-tests.factor → basis/db/pools/pools-tests.factor
View File

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

0
extra/db/pools/pools.factor → basis/db/pools/pools.factor
View File

0
basis/units/authors.txt → basis/db/postgresql/authors.txt Executable file → Normal file
View File

0
extra/db/postgresql/ffi/ffi.factor → basis/db/postgresql/ffi/ffi.factor
View File

0
extra/db/postgresql/lib/lib.factor → basis/db/postgresql/lib/lib.factor
View File

0
extra/db/postgresql/postgresql-tests.factor → basis/db/postgresql/postgresql-tests.factor
View File

6
extra/db/postgresql/postgresql.factor → basis/db/postgresql/postgresql.factor
View File

@ -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

18
extra/db/queries/queries.factor → basis/db/queries/queries.factor
View File

@ -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 <select-by-slots-statement> ( 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 ;

0
extra/db/sql/sql-tests.factor → basis/db/sql/sql-tests.factor
View File

4
extra/db/sql/sql.factor → basis/db/sql/sql.factor
View File

@ -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

0
extra/db/sqlite/authors.txt → basis/db/sqlite/authors.txt
View File

2
extra/db/sqlite/ffi/ffi.factor → basis/db/sqlite/ffi/ffi.factor
View File

@ -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 ;

0
extra/db/sqlite/lib/lib.factor → basis/db/sqlite/lib/lib.factor
View File

3
extra/db/sqlite/sqlite-tests.factor → basis/db/sqlite/sqlite-tests.factor
View File

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

20
extra/db/sqlite/sqlite.factor → basis/db/sqlite/sqlite.factor
View File

@ -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 )

0
extra/db/sqlite/test.txt → basis/db/sqlite/test.txt
View File

0
extra/db/summary.txt → basis/db/summary.txt
View File

0
extra/db/tags.txt → basis/db/tags.txt
View File

8
extra/db/tuples/tuples-tests.factor → basis/db/tuples/tuples-tests.factor
View File

@ -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

10
extra/db/tuples/tuples.factor → basis/db/tuples/tuples.factor
View File

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

26
extra/db/types/types.factor → basis/db/types/types.factor
View File

@ -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>> ;

6
basis/debugger/debugger-docs.factor
View File

@ -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"

7
basis/debugger/threads/threads.factor
View File

@ -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 ;

6
basis/delegate/delegate-tests.factor
View File

@ -15,7 +15,7 @@ GENERIC# whoa 1 ( s t -- w )
PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
: hello-test ( hello/goodbye -- array )
[ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
[ hello? ] [ this>> ] [ that>> ] tri 3array ;
CONSULT: baz goodbye these>> ;
M: hello foo this>> ;
@ -34,8 +34,8 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ 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

4
basis/editors/gvim/backend/backend.factor
View File

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

1
basis/editors/gvim/backend/tags.txt
View File

@ -1 +0,0 @@
unportable

4
basis/editors/gvim/gvim.factor
View File

@ -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 ;

2
basis/editors/gvim/unix/unix.factor
View File

@ -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

2
basis/editors/gvim/windows/windows.factor
View File

@ -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

0
extra/farkup/authors.txt → basis/farkup/authors.txt
View File

0
extra/farkup/farkup-docs.factor → basis/farkup/farkup-docs.factor
View File

2
extra/farkup/farkup-tests.factor → basis/farkup/farkup-tests.factor
View File

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

0
extra/farkup/farkup.factor → basis/farkup/farkup.factor
View File

0
extra/farkup/summary.txt → basis/farkup/summary.txt
View File

0
extra/farkup/tags.txt → basis/farkup/tags.txt
View File

2
basis/float-arrays/float-arrays.factor
View File

@ -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 ;

Some files were not shown because too many files have changed in this diff Show More