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

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

db4
Bruno Deferrari 2008-09-03 23:53:38 -03:00
parent 504530276f b0e16704e6
commit ccf17e50d2
320 changed files with 2796 additions and 1479 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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 ;

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 )

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

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+

84
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 ;
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,15 +120,15 @@ PRIVATE>
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
MEMO: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
: years ( n -- dt ) instant clone swap >>year ;
: months ( n -- dt ) instant clone swap >>month ;
: days ( n -- dt ) instant clone swap >>day ;
: weeks ( n -- dt ) 7 * days ;
: hours ( n -- dt ) instant clone swap >>hour ;
: minutes ( n -- dt ) instant clone swap >>minute ;
: seconds ( n -- dt ) instant clone swap >>second ;
: milliseconds ( n -- dt ) 1000 / seconds ;
: 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 ;
: weeks ( x -- duration ) 7 * days ;
: hours ( x -- duration ) instant clone swap >>hour ;
: minutes ( x -- duration ) instant clone swap >>minute ;
: seconds ( x -- duration ) instant clone swap >>second ;
: milliseconds ( x -- duration ) 1000 / seconds ;
GENERIC: leap-year? ( obj -- ? )
@ -218,7 +222,7 @@ M: number +second ( timestamp n -- timestamp )
PRIVATE>
GENERIC# time+ 1 ( time dt -- time )
GENERIC# time+ 1 ( time1 time2 -- time3 )
M: timestamp time+
>r clone r> (time+) drop ;
@ -236,8 +240,8 @@ M: duration time+
2drop <duration>
] if ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar
: duration>years ( duration -- x )
#! Uses average month/year length since duration loses calendar
#! data
0 swap
{
@ -249,16 +253,16 @@ M: duration time+
[ second>> seconds-per-year / + ]
} cleave ;
M: duration <=> [ dt>years ] compare ;
M: duration <=> [ duration>years ] compare ;
: dt>months ( dt -- x ) dt>years months-per-year * ;
: dt>days ( dt -- x ) dt>years days-per-year * ;
: dt>hours ( dt -- x ) dt>years hours-per-year * ;
: dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
: dt>milliseconds ( dt -- 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 ] [
@ -296,23 +300,23 @@ M: timestamp time-
} 2cleave <duration>
] if ;
: before ( dt -- -dt )
: before ( duration -- -duration )
-1 time* ;
M: duration time-
before time+ ;
MEMO: <zero> ( -- timestamp )
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 )
@ -323,11 +327,8 @@ MEMO: unix-1970 ( -- timestamp )
unix-1970 millis milliseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
: hence ( dt -- timestamp ) now swap time+ ;
: ago ( dt -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
@ -363,19 +364,21 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: day-of-year ( timestamp -- n )
>date< (day-of-year) ;
<PRIVATE
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp )
day-offset days time+ ;
PRIVATE>
: sunday ( timestamp -- timestamp ) 0 day-this-week ;
: 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
@ -395,7 +398,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: time-since-midnight ( timestamp -- duration )
dup midnight time- ;
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep hence sleep-until ;

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 )

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* ;
[

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

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 ;

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/calendar/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

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors combinators.lib ;
tools.walker accessors combinators.lib combinators ;
IN: db
TUPLE: db
@ -15,24 +15,25 @@ TUPLE: db
new
H{ } clone >>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ;
H{ } clone >>delete-statements ; inline
GENERIC: make-db* ( seq class -- db )
GENERIC: make-db* ( seq db -- db )
: make-db ( seq class -- db )
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/editors/gvim/backend/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

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

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

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

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

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

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

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')"

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

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

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

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

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

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

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

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

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

4
basis/float-vectors/float-vectors-tests.factor
View File

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

6
basis/help/definitions/definitions-tests.factor
View File

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

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

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

14
basis/help/lint/lint.factor
View File

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

6
basis/help/markup/markup-tests.factor
View File

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

5
basis/help/syntax/syntax-tests.factor
View File

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

9
basis/help/topics/topics-docs.factor
View File

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

8
basis/help/topics/topics-tests.factor
View File

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

1
basis/hints/hints-docs.factor
View File

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

2
basis/io/buffers/buffers-tests.factor
View File

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

9
basis/io/encodings/ascii/ascii-docs.factor
View File

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

2
basis/io/encodings/utf16/utf16-docs.factor
View File

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

2
basis/io/servers/connection/connection-tests.factor
View File

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

8
basis/io/sockets/sockets.factor
View File

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

22
basis/io/windows/launcher/launcher.factor
View File

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

5
basis/io/windows/nt/backend/backend.factor
View File

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

155
basis/io/windows/nt/sockets/sockets.factor
View File

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

4
basis/macros/expander/expander.factor
View File

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

10
basis/math/complex/complex-docs.factor
View File

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

25
basis/math/complex/complex-tests.factor
View File

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

10
basis/math/complex/complex.factor
View File

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

2
basis/math/functions/functions-docs.factor
View File

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

9
basis/math/functions/functions-tests.factor
View File

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

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