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

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

db4
Eduardo Cavazos 2008-09-03 02:18:37 -05:00
parent a24645fbca 3b3435acb5
commit f374105084
197 changed files with 1038 additions and 700 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,10 +5,10 @@ math.order ;
IN: calendar
HELP: duration
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ;
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
HELP: timestamp
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ;
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ;
{ timestamp duration } related-words
@ -135,35 +135,37 @@ HELP: instant
HELP: years
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of years." } ;
HELP: months
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of months." } ;
HELP: days
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of days." } ;
HELP: weeks
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of weeks." } ;
HELP: hours
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of hours." } ;
HELP: minutes
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of minutes." } ;
HELP: seconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $description "Creates a duration object with the specified number of seconds." } ;
HELP: milliseconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
{ $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" } }
@ -193,75 +195,75 @@ HELP: time+
}
} ;
HELP: dt>years
HELP: duration>years
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in years." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"6 months dt>years ."
"6 months duration>years ."
"1/2"
}
} ;
HELP: dt>months
HELP: duration>months
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in months." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"30 days dt>months ."
"30 days duration>months ."
"16000/16233"
}
} ;
HELP: dt>days
HELP: duration>days
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in days." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"6 hours dt>days ."
"6 hours duration>days ."
"1/4"
}
} ;
HELP: dt>hours
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 dt>hours ."
"3/4 days duration>hours ."
"18"
}
} ;
HELP: dt>minutes
HELP: duration>minutes
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in minutes." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"6 hours dt>minutes ."
"6 hours duration>minutes ."
"360"
}
} ;
HELP: dt>seconds
HELP: duration>seconds
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in seconds." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"6 minutes dt>seconds ."
"6 minutes duration>seconds ."
"360"
}
} ;
HELP: dt>milliseconds
HELP: duration>milliseconds
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in milliseconds." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"6 seconds dt>milliseconds ."
"6 seconds duration>milliseconds ."
"6000"
}
} ;
{ dt>years dt>months dt>days dt>hours dt>minutes dt>seconds dt>milliseconds } related-words
{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words
HELP: time-
@ -428,16 +430,6 @@ HELP: day-of-year
}
} ;
HELP: day-this-week
{ $values { "timestamp" timestamp } { "n" integer } { "timestamp" timestamp } }
{ $description "Implementation word to calculate the day of the week relative to the timestamp. Sunday is the first day of the week, so the resulting " { $snippet "timestamp" } " will be Sunday or after, and before Saturday." }
{ $examples
{ $example "USING: calendar kernel prettyprint ;"
"now 0 day-this-week now sunday = ."
"t"
}
} ;
HELP: sunday
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
{ $description "Returns the Sunday from the current week, which starts on a Sunday." } ;
@ -491,3 +483,124 @@ HELP: beginning-of-year
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+

18
basis/calendar/calendar.factor
View File

@ -240,7 +240,7 @@ M: duration time+
2drop <duration>
] if ;
: dt>years ( duration -- x )
: duration>years ( duration -- x )
#! Uses average month/year length since duration loses calendar
#! data
0 swap
@ -253,14 +253,14 @@ M: duration time+
[ second>> seconds-per-year / + ]
} cleave ;
M: duration <=> [ dt>years ] compare ;
M: duration <=> [ duration>years ] compare ;
: dt>months ( duration -- x ) dt>years months-per-year * ;
: dt>days ( duration -- x ) dt>years days-per-year * ;
: dt>hours ( duration -- x ) dt>years hours-per-year * ;
: dt>minutes ( duration -- x ) dt>years minutes-per-year * ;
: dt>seconds ( duration -- x ) dt>years seconds-per-year * ;
: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ;
: duration>months ( duration -- x ) duration>years months-per-year * ;
: duration>days ( duration -- x ) duration>years days-per-year * ;
: duration>hours ( duration -- x ) duration>years hours-per-year * ;
: duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
: duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ;
GENERIC: time- ( time1 time2 -- time3 )
@ -364,11 +364,13 @@ 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 -- new-timestamp ) 0 day-this-week ;
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;

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

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"

2
basis/compiler/tests/alien.factor
View File

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

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

@ -1,7 +1,15 @@
! 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 accessors sequences words namespaces
classes.builtin
compiler.tree
compiler.tree.builder
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.combinators ;
IN: compiler.tree.finalization
GENERIC: finalize* ( node -- nodes )
@ -13,6 +21,25 @@ M: #shuffle finalize*
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
: builtin-predicate? ( word -- ? )
"predicating" word-prop builtin-class? ;
: splice-quot ( quot -- nodes )
[
build-tree
normalize
propagate
cleanup
compute-def-use
remove-dead-code
but-last
] with-scope ;
M: #call finalize*
dup word>> builtin-predicate? [
word>> def>> splice-quot
] when ;
M: node finalize* ;
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

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

@ -59,10 +59,38 @@ slots ;
: <value-info> ( -- info ) \ value-info new ;
: read-only-slots ( values class -- slots )
#! Delegation.
all-slots rest-slice
[ read-only>> [ drop f ] unless ] 2map
{ f f } prepend ;
DEFER: <literal-info>
: init-literal-info ( info -- info )
#! Delegation.
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 rest-slice
[ <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
@ -73,7 +101,7 @@ slots ;
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if
] if ;
] if ; inline
: <class/interval-info> ( class interval -- info )
<value-info>

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

@ -211,7 +211,7 @@ generic-comparison-ops [
\ eq? [
[ info-intervals-intersect? ]
[ info-classes-intersect? ]
2bi or maybe-or-never
2bi and maybe-or-never
] "outputs" set-word-prop
{

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

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

@ -31,12 +31,6 @@ 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-info> ;

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 ;

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

@ -11,17 +11,17 @@ math.floats.private classes slots.private combinators
compiler.constants ;
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 +188,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 +259,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
@ -514,8 +514,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{
@ -539,6 +539,7 @@ IN: cpu.ppc.intrinsics
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "value" "offset" } }
} ;

0
extra/db/authors.txt → basis/db/authors.txt
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 ;

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

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

0
extra/db/postgresql/authors.txt → basis/db/postgresql/authors.txt
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"

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/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: } "." } ;

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

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

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 }

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

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

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

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

87
basis/math/functions/functions.factor
View File

@ -7,7 +7,7 @@ IN: math.functions
<PRIVATE
: (rect>) ( x y -- z )
dup zero? [ drop ] [ <complex> ] if ; inline
dup 0 = [ drop ] [ <complex> ] if ; inline
PRIVATE>
@ -24,29 +24,57 @@ M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot: ( ? -- ) -- )
over 0 number= pick -1 number= or [
over 0 = pick -1 = or [
2drop
] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline recursive
GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w )
1 swap [
[ dupd * ] when >r sq r>
] each-bit nip ; inline
M: integer (^)
dup 0 < [ neg ^n recip ] [ ^n ] if ;
: integer^ ( x y -- z )
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
: >rect ( z -- x y )
[ real-part ] [ imaginary-part ] bi ; inline
: >float-rect ( z -- x y )
>rect [ >float ] bi@ ; inline
: >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ;
inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline
: ^mag ( w abs arg -- magnitude )
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
inline
: ^theta ( w abs arg -- theta )
>r >r >float-rect r> flog * swap r> * + ; inline
: ^complex ( x y -- z )
swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline
: real^? ( x y -- ? )
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
: ^ ( x y -- z )
over zero? [
dup zero?
[ 2drop 0.0 0.0 / ] [ 0 < [ drop 1.0 0.0 / ] when ] if
] [
(^)
] if ; inline
{
{ [ over zero? ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] }
[ ^complex ]
} cond ;
: (^mod) ( n x y -- z )
1 swap [
@ -98,42 +126,27 @@ M: real absq sq ;
[ ~abs ]
} cond ;
: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline
: >float-rect ( z -- x y )
>rect swap >float swap >float ; inline
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
: >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ;
inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline
: ^mag ( w abs arg -- magnitude )
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
inline
: ^theta ( w abs arg -- theta )
>r >r >float-rect r> flog * swap r> * + ; inline
M: number (^)
swap >polar 3dup ^theta >r ^mag r> polar> ;
: [-1,1]? ( x -- ? )
dup complex? [ drop f ] [ abs 1 <= ] if ; inline
: >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline
: exp ( x -- y ) >rect swap fexp swap polar> ; inline
GENERIC: exp ( x -- y )
: log ( x -- y ) >polar swap flog swap rect> ; inline
M: real exp fexp ;
M: complex exp >rect swap fexp swap polar> ;
GENERIC: log ( x -- y )
M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
M: complex log >polar swap flog swap rect> ;
: cos ( x -- y )
dup complex? [

5
basis/math/geometry/rect/rect-docs.factor
View File

@ -17,11 +17,6 @@ HELP: <rect> ( loc dim -- rect )
{ <zero-rect> <rect> <extent-rect> } related-words
HELP: set-rect-dim ( dim rect -- )
{ $values { "dim" "a pair of integers" } { "rect" rect } }
{ $description "Modifies the dimensions of a rectangle." }
{ $side-effects "rect" } ;
HELP: rect-bounds
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Outputs the location and dimensions of a rectangle." } ;

7
basis/math/geometry/rect/rect.factor
View File

@ -7,6 +7,9 @@ IN: math.geometry.rect
TUPLE: rect loc dim ;
GENERIC: rect-loc ( obj -- loc )
GENERIC: rect-dim ( obj -- dim )
: init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ;
: <rect> ( loc dim -- rect ) rect boa ;
@ -17,6 +20,10 @@ M: array rect-loc ;
M: array rect-dim drop { 0 0 } ;
M: rect rect-loc loc>> ;
M: rect rect-dim dim>> ;
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;

6
basis/math/intervals/intervals-tests.factor
View File

@ -60,11 +60,11 @@ IN: math.intervals.tests
] unit-test
[ t ] [
1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] =
1 2 [a,b] -0.5 0.5 [a,b] interval* -1.0 1.0 [a,b] =
] unit-test
[ t ] [
1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] =
1 2 [a,b] -0.5 0.5 (a,b] interval* -1.0 1.0 (a,b] =
] unit-test
[ t ] [
@ -131,7 +131,7 @@ IN: math.intervals.tests
"math.ratios.private" vocab [
[ t ] [
-1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) =
-1 1 (a,b) 0.5 1 (a,b) interval/ -2.0 2.0 (a,b) =
] unit-test
] when

4
basis/math/ratios/ratios-tests.factor
View File

@ -81,8 +81,8 @@ unit-test
[ -1/2 ] [ 1/2 1- ] unit-test
[ 3/2 ] [ 1/2 1+ ] unit-test
[ 1 ] [ 0.5 1/2 + ] unit-test
[ 1 ] [ 1/2 0.5 + ] unit-test
[ 1.0 ] [ 0.5 1/2 + ] unit-test
[ 1.0 ] [ 1/2 0.5 + ] unit-test
[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test

8
basis/math/ratios/ratios.factor
View File

@ -30,6 +30,14 @@ M: integer /
2dup gcd nip tuck /i >r /i r> fraction>
] if ;
M: ratio hashcode*
nip >fraction [ hashcode ] bi@ bitxor ;
M: ratio equal?
over ratio? [
2>fraction = [ = ] [ 2drop f ] if
] [ 2drop f ] if ;
M: ratio number=
2>fraction number= [ number= ] [ 2drop f ] if ;

2
basis/mirrors/mirrors-tests.factor
View File

@ -15,7 +15,7 @@ C: <foo> foo
[ f f ] [ "hi" 1 2 <foo> <mirror> at* ] unit-test
[ 3 ] [
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep baz>>
] unit-test
[ 3 "hi" 1 2 <foo> <mirror> set-at ] must-fail

10
basis/models/compose/compose-tests.factor
View File

@ -1,6 +1,6 @@
IN: models.compose.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.compose ;
tools.test models.compose accessors ;
IN: models.compose.tests
! Test compose
[ ] [
@ -11,14 +11,14 @@ tools.test models.compose ;
[ ] [ "c" get activate-model ] unit-test
[ { 1 2 } ] [ "c" get model-value ] unit-test
[ { 1 2 } ] [ "c" get value>> ] unit-test
[ ] [ 3 "b" get set-model ] unit-test
[ { 1 3 } ] [ "c" get model-value ] unit-test
[ { 1 3 } ] [ "c" get value>> ] unit-test
[ ] [ { 4 5 } "c" get set-model ] unit-test
[ { 4 5 } ] [ "c" get model-value ] unit-test
[ { 4 5 } ] [ "c" get value>> ] unit-test
[ ] [ "c" get deactivate-model ] unit-test

4
basis/models/compose/compose.factor
View File

@ -18,12 +18,12 @@ TUPLE: compose < model ;
M: compose model-changed
nip
[ [ model-value ] composed-value ] keep set-model ;
[ [ value>> ] composed-value ] keep set-model ;
M: compose model-activated dup model-changed ;
M: compose update-model
dup model-value swap [ set-model ] set-composed-value ;
dup value>> swap [ set-model ] set-composed-value ;
M: compose range-value
[ range-value ] composed-value ;

14
basis/models/filter/filter-tests.factor
View File

@ -1,18 +1,18 @@
IN: models.filter.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.filter ;
tools.test models.filter accessors ;
IN: models.filter.tests
! Test multiple filters
3 <model> "x" set
"x" get [ 2 * ] <filter> dup "z" set
[ 1+ ] <filter> "y" set
[ ] [ "y" get activate-model ] unit-test
[ t ] [ "z" get "x" get model-connections memq? ] unit-test
[ 7 ] [ "y" get model-value ] unit-test
[ t ] [ "z" get "x" get connections>> memq? ] unit-test
[ 7 ] [ "y" get value>> ] unit-test
[ ] [ 4 "x" get set-model ] unit-test
[ 9 ] [ "y" get model-value ] unit-test
[ 9 ] [ "y" get value>> ] unit-test
[ ] [ "y" get deactivate-model ] unit-test
[ f ] [ "z" get "x" get model-connections memq? ] unit-test
[ f ] [ "z" get "x" get connections>> memq? ] unit-test
3 <model> "x" set
"x" get [ sq ] <filter> "y" set
@ -20,5 +20,5 @@ tools.test models.filter ;
4 "x" get set-model
"y" get activate-model
[ 16 ] [ "y" get model-value ] unit-test
[ 16 ] [ "y" get value>> ] unit-test
"y" get deactivate-model

28
basis/models/history/history-tests.factor
View File

@ -1,37 +1,37 @@
IN: models.history.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.history ;
tools.test models.history accessors ;
IN: models.history.tests
f <history> "history" set
"history" get add-history
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
[ t ] [ "history" get back>> empty? ] unit-test
[ t ] [ "history" get forward>> empty? ] unit-test
"history" get add-history
3 "history" get set-model
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
[ t ] [ "history" get back>> empty? ] unit-test
[ t ] [ "history" get forward>> empty? ] unit-test
"history" get add-history
4 "history" get set-model
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
[ f ] [ "history" get back>> empty? ] unit-test
[ t ] [ "history" get forward>> empty? ] unit-test
"history" get go-back
[ 3 ] [ "history" get model-value ] unit-test
[ 3 ] [ "history" get value>> ] unit-test
[ t ] [ "history" get history-back empty? ] unit-test
[ f ] [ "history" get history-forward empty? ] unit-test
[ t ] [ "history" get back>> empty? ] unit-test
[ f ] [ "history" get forward>> empty? ] unit-test
"history" get go-forward
[ 4 ] [ "history" get model-value ] unit-test
[ 4 ] [ "history" get value>> ] unit-test
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
[ f ] [ "history" get back>> empty? ] unit-test
[ t ] [ "history" get forward>> empty? ] unit-test

12
basis/models/mapping/mapping-tests.factor
View File

@ -1,6 +1,6 @@
IN: models.mapping.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.mapping ;
tools.test models.mapping accessors ;
IN: models.mapping.tests
! Test mapping
[ ] [
@ -14,7 +14,7 @@ tools.test models.mapping ;
[ ] [ "m" get activate-model ] unit-test
[ H{ { "one" 1 } { "two" 2 } } ] [
"m" get model-value
"m" get value>>
] unit-test
[ ] [
@ -23,12 +23,12 @@ tools.test models.mapping ;
] unit-test
[ H{ { "one" 3 } { "two" 4 } } ] [
"m" get model-value
"m" get value>>
] unit-test
[ H{ { "one" 5 } { "two" 4 } } ] [
5 "one" "m" get mapping-assoc at set-model
"m" get model-value
5 "one" "m" get assoc>> at set-model
"m" get value>>
] unit-test
[ ] [ "m" get deactivate-model ] unit-test

11
basis/models/models-tests.factor
View File

@ -1,13 +1,12 @@
IN: models.tests
USING: arrays generic kernel math models models.compose
namespaces sequences assocs
tools.test ;
namespaces sequences assocs accessors tools.test ;
IN: models.tests
TUPLE: model-tester hit? ;
: <model-tester> model-tester new ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
M: model-tester model-changed nip t >>hit? drop ;
[ T{ model-tester f t } ]
[
@ -20,7 +19,7 @@ M: model-tester model-changed nip t swap set-model-tester-hit? ;
"model-a" get "model-b" get 2array <compose> "model-c" set
"model-c" get activate-model
[ { 3 4 } ] [ "model-c" get model-value ] unit-test
[ { 3 4 } ] [ "model-c" get value>> ] unit-test
"model-c" get deactivate-model
T{ model-tester f f } "tester" set
@ -30,5 +29,5 @@ T{ model-tester f f } "tester" set
"tester" get "model-c" get add-connection
6 "model-a" get set-model
"tester" get
"model-c" get model-value
"model-c" get value>>
] unit-test

6
basis/opengl/capabilities/capabilities.factor
View File

@ -5,9 +5,9 @@ continuations math.parser math arrays sets math.order ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
>r dupd call
[ r> 2drop ]
[ r> " " make throw ]
-rot dupd call
[ 2drop ]
[ swap " " make throw ]
if ; inline
: gl-extensions ( -- seq )

2
basis/stack-checker/stack-checker-tests.factor
View File

@ -148,7 +148,7 @@ M: fixnum potential-hang dup [ potential-hang ] when ;
TUPLE: funny-cons car cdr ;
GENERIC: iterate ( obj -- )
M: funny-cons iterate funny-cons-cdr iterate ;
M: funny-cons iterate cdr>> iterate ;
M: f iterate drop ;
M: real iterate drop ;

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -246,7 +246,7 @@ IN: tools.deploy.shaker
word
} %
{ } { "optimizer.math.partial" } strip-vocab-globals %
{ } { "math.partial-dispatch" } strip-vocab-globals %
] when
strip-prettyprint? [

5
basis/tuple-arrays/tuple-arrays-tests.factor
View File

@ -1,4 +1,5 @@
USING: tuple-arrays sequences tools.test namespaces kernel math accessors ;
USING: tuple-arrays sequences tools.test namespaces kernel
math accessors ;
IN: tuple-arrays.tests
SYMBOL: mat
@ -9,7 +10,7 @@ C: <foo> foo
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ T{ foo f 3 } t ]
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test

32
basis/ui/cocoa/cocoa.factor
View File

@ -24,10 +24,10 @@ TUPLE: pasteboard handle ;
C: <pasteboard> pasteboard
M: pasteboard clipboard-contents
pasteboard-handle pasteboard-string ;
handle>> pasteboard-string ;
M: pasteboard set-clipboard-contents
pasteboard-handle set-pasteboard-string ;
handle>> set-pasteboard-string ;
: init-clipboard ( -- )
NSPasteboard -> generalPasteboard <pasteboard>
@ -44,29 +44,29 @@ M: pasteboard set-clipboard-contents
dup install-window-delegate
over -> release
<handle>
] keep set-world-handle ;
] keep (>>handle) ;
M: cocoa-ui-backend set-title ( string world -- )
world-handle handle-window swap <NSString> -> setTitle: ;
handle>> window>> swap <NSString> -> setTitle: ;
: enter-fullscreen ( world -- )
world-handle handle-view
handle>> view>>
NSScreen -> mainScreen
f -> enterFullScreenMode:withOptions:
drop ;
: exit-fullscreen ( world -- )
world-handle handle-view f -> exitFullScreenModeWithOptions: ;
handle>> view>> f -> exitFullScreenModeWithOptions: ;
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen* ( world -- ? )
world-handle handle-view -> isInFullScreenMode zero? not ;
handle>> view>> -> isInFullScreenMode zero? not ;
: auto-position ( world -- )
dup window-loc>> { 0 0 } = [
world-handle handle-window -> center
handle>> window>> -> center
] [
drop
] if ;
@ -74,29 +74,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
M: cocoa-ui-backend (open-window) ( world -- )
dup gadget-window
dup auto-position
world-handle handle-window f -> makeKeyAndOrderFront: ;
handle>> window>> f -> makeKeyAndOrderFront: ;
M: cocoa-ui-backend (close-window) ( handle -- )
handle-window -> release ;
window>> -> release ;
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
world-handle [
handle-window f -> performClose:
handle>> [
window>> f -> performClose:
] when*
] when* ;
M: cocoa-ui-backend raise-window* ( world -- )
world-handle [
handle-window dup f -> orderFront: -> makeKeyWindow
handle>> [
window>> dup f -> orderFront: -> makeKeyWindow
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
M: cocoa-ui-backend select-gl-context ( handle -- )
handle-view -> openGLContext -> makeCurrentContext ;
view>> -> openGLContext -> makeCurrentContext ;
M: cocoa-ui-backend flush-gl-context ( handle -- )
handle-view -> openGLContext -> flushBuffer ;
view>> -> openGLContext -> flushBuffer ;
M: cocoa-ui-backend beep ( -- )
NSBeep ;

2
basis/ui/gadgets/borders/borders.factor
View File

@ -41,7 +41,7 @@ M: border pref-dim*
M: border layout*
dup border-child-rect swap gadget-child
over loc>> over set-rect-loc
over loc>> >>loc
swap dim>> swap (>>dim) ;
M: border focusable-child*

9
basis/ui/gadgets/buttons/buttons-tests.factor
View File

@ -1,6 +1,7 @@
IN: ui.gadgets.buttons.tests
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
ui.gadgets tools.test namespaces sequences kernel models ;
ui.gadgets tools.test namespaces sequences kernel models
accessors ;
IN: ui.gadgets.buttons.tests
TUPLE: foo-gadget ;
@ -15,7 +16,7 @@ TUPLE: foo-gadget ;
T{ foo-gadget } <toolbar> "t" set
[ 2 ] [ "t" get gadget-children length ] unit-test
[ 2 ] [ "t" get children>> length ] unit-test
[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
[ ] [
@ -34,7 +35,7 @@ T{ foo-gadget } <toolbar> "t" set
\ <checkbox> must-infer
[ 0 ] [
"religion" get gadget-child radio-control-value
"religion" get gadget-child value>>
] unit-test
[ 2 ] [

4
basis/ui/gadgets/buttons/buttons.factor
View File

@ -148,7 +148,7 @@ TUPLE: checkbox < button ;
align-left ;
M: checkbox model-changed
swap model-value over (>>selected?) relayout-1 ;
swap value>> over (>>selected?) relayout-1 ;
TUPLE: radio-paint color ;
@ -187,7 +187,7 @@ TUPLE: radio-control < button value ;
align-left ; inline
M: radio-control model-changed
swap model-value
swap value>>
over value>> =
over (>>selected?)
relayout-1 ;

4
basis/ui/gadgets/canvas/canvas-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: ui.gadgets.canvas.tests
USING: ui.gadgets.canvas tools.test kernel ;
{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as

14
basis/ui/gadgets/canvas/canvas.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
classes.tuple colors ;
classes.tuple colors accessors ;
IN: ui.gadgets.canvas
TUPLE: canvas < gadget dlist ;
@ -11,16 +11,16 @@ TUPLE: canvas < gadget dlist ;
new-gadget black solid-interior ; inline
: delete-canvas-dlist ( canvas -- )
dup find-gl-context
dup canvas-dlist [ delete-dlist ] when*
f swap set-canvas-dlist ;
[ find-gl-context ]
[ dlist>> [ delete-dlist ] when* ]
[ f >>dlist drop ] tri ;
: make-canvas-dlist ( canvas quot -- dlist )
over >r GL_COMPILE swap make-dlist dup r>
set-canvas-dlist ;
[ drop ] [ GL_COMPILE swap make-dlist ] 2bi
[ >>dlist drop ] keep ; inline
: cache-canvas-dlist ( canvas quot -- dlist )
over canvas-dlist dup
over dlist>> dup
[ 2nip ] [ drop make-canvas-dlist ] if ; inline
: draw-canvas ( canvas quot -- )

5
basis/ui/gadgets/editors/editors-tests.factor
View File

@ -2,6 +2,7 @@ USING: accessors ui.gadgets.editors tools.test kernel io
io.streams.plain definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
models ;
IN: ui.gadgets.editors.tests
[ "foo bar" ] [
<editor> "editor" set
@ -34,7 +35,7 @@ models ;
<editor> "editor" set
"editor" get [
"bar\nbaz quux" "editor" get set-editor-string
{ 0 3 } "editor" get editor-caret set-model
{ 0 3 } "editor" get caret>> set-model
"editor" get select-word
"editor" get gadget-selection
] with-grafted-gadget
@ -45,5 +46,5 @@ models ;
"hello" <model> <field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model>> model-value ] unit-test
[ "hello" ] [ "field" get field-model>> value>> ] unit-test
] with-grafted-gadget

66
basis/ui/gadgets/gadgets-tests.factor
View File

@ -1,8 +1,8 @@
IN: ui.gadgets.tests
USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
tools.test namespaces models kernel dlists deques math sets
math.parser ui sequences hashtables assocs io arrays prettyprint
io.streams.string math.geometry.rect ;
IN: ui.gadgets.tests
[ { 300 300 } ]
[
@ -14,24 +14,24 @@ io.streams.string math.geometry.rect ;
"b" get "c" get swap add-gadget drop
! position a and b
{ 100 200 } "a" get set-rect-loc
{ 200 100 } "b" get set-rect-loc
"a" get { 100 200 } >>loc drop
"b" get { 200 100 } >>loc drop
! give c a loc, it doesn't matter
{ -1000 23 } "c" get set-rect-loc
"c" get { -1000 23 } >>loc drop
! what is the location of a inside c?
"a" get "c" get relative-loc
] unit-test
<gadget> "g1" set
{ 10 10 } "g1" get set-rect-loc
{ 30 30 } "g1" get set-rect-dim
"g1" get { 10 10 } >>loc
{ 30 30 } >>dim drop
<gadget> "g2" set
{ 20 20 } "g2" get set-rect-loc
{ 50 500 } "g2" get set-rect-dim
"g2" get { 20 20 } >>loc
{ 50 500 } >>dim drop
<gadget> "g3" set
{ 100 200 } "g3" get set-rect-dim
"g3" get { 100 200 } >>dim drop
"g1" get "g2" get swap add-gadget drop
"g2" get "g3" get swap add-gadget drop
@ -47,15 +47,15 @@ io.streams.string math.geometry.rect ;
[ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
<gadget> "g1" set
{ 300 300 } "g1" get set-rect-dim
"g1" get { 300 300 } >>dim drop
<gadget> "g2" set
"g2" get "g1" get swap add-gadget drop
{ 20 20 } "g2" get set-rect-loc
{ 20 20 } "g2" get set-rect-dim
"g2" get { 20 20 } >>loc
{ 20 20 } >>dim drop
<gadget> "g3" set
"g3" get "g1" get swap add-gadget drop
{ 100 100 } "g3" get set-rect-loc
{ 20 20 } "g3" get set-rect-dim
"g3" get { 100 100 } >>loc
{ 20 20 } >>dim drop
[ t ] [ { 30 30 } "g2" get inside? ] unit-test
@ -67,8 +67,8 @@ io.streams.string math.geometry.rect ;
<gadget> "g4" set
"g4" get "g2" get swap add-gadget drop
{ 5 5 } "g4" get set-rect-loc
{ 1 1 } "g4" get set-rect-dim
"g4" get { 5 5 } >>loc
{ 1 1 } >>dim drop
[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
@ -78,12 +78,10 @@ TUPLE: mock-gadget < gadget graft-called ungraft-called ;
mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
M: mock-gadget graft*
dup mock-gadget-graft-called 1+
swap set-mock-gadget-graft-called ;
[ 1+ ] change-graft-called drop ;
M: mock-gadget ungraft*
dup mock-gadget-ungraft-called 1+
swap set-mock-gadget-ungraft-called ;
[ 1+ ] change-ungraft-called drop ;
! We can't print to output-stream here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
@ -100,35 +98,35 @@ M: mock-gadget ungraft*
<mock-gadget> "g" set
[ ] [ "g" get queue-graft ] unit-test
[ f ] [ graft-queue deque-empty? ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ { f t } ] [ "g" get graft-state>> ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ { f t } ] [ "g" get graft-state>> ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
[ { f f } ] [ "g" get graft-state>> ] unit-test
[ t ] [ graft-queue deque-empty? ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ ] [ notify-queued ] unit-test
[ { t t } ] [ "g" get gadget-graft-state ] unit-test
[ { t t } ] [ "g" get graft-state>> ] unit-test
[ t ] [ graft-queue deque-empty? ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
[ 1 ] [ "g" get graft-called>> ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { t f } ] [ "g" get gadget-graft-state ] unit-test
[ { t f } ] [ "g" get graft-state>> ] unit-test
[ ] [ notify-queued ] unit-test
[ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
[ 1 ] [ "g" get ungraft-called>> ] unit-test
[ { f f } ] [ "g" get graft-state>> ] unit-test
] with-variable
: add-some-children
3 [
<mock-gadget> over <model> over set-gadget-model
<mock-gadget> over <model> >>model
dup "g" get swap add-gadget drop
swap 1+ number>string set
] each ;
: status-flags
{ "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
{ "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
: notify-combo ( ? ? -- )
nl "===== Combo: " write 2dup 2array . nl
@ -140,12 +138,12 @@ M: mock-gadget ungraft*
[ V{ { f t } } ] [ status-flags ] unit-test
dup [ [ ] [ notify-queued ] unit-test ] when
[ ] [ "g" get clear-gadget ] unit-test
[ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
[ [ 1 ] [ graft-queue length>> ] unit-test ] unless
[ [ ] [ notify-queued ] unit-test ] when
[ ] [ add-some-children ] unit-test
[ { f t } ] [ "1" get gadget-graft-state ] unit-test
[ { f t } ] [ "2" get gadget-graft-state ] unit-test
[ { f t } ] [ "3" get gadget-graft-state ] unit-test
[ { f t } ] [ "1" get graft-state>> ] unit-test
[ { f t } ] [ "2" get graft-state>> ] unit-test
[ { f t } ] [ "3" get graft-state>> ] unit-test
[ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
[ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test

6
basis/ui/gadgets/grids/grids-tests.factor
View File

@ -1,10 +1,10 @@
USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
namespaces math.geometry.rect ;
namespaces math.geometry.rect accessors ;
IN: ui.gadgets.grids.tests
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
: 100x100 <gadget> { 100 100 } over set-rect-dim ;
: 100x100 <gadget> { 100 100 } >>dim ;
[ { 100 100 } ] [
100x100
@ -38,7 +38,7 @@ IN: ui.gadgets.grids.tests
100x100 dup "a" set
100x100 dup "b" set
2array 1array <grid>
{ 10 10 } over set-grid-gap
{ 10 10 } >>gap
dup prefer
dup layout
rect-dim

2
basis/ui/gadgets/grids/grids.factor
View File

@ -62,7 +62,7 @@ M: grid pref-dim*
: position-grid ( grid horiz vert -- )
pick >r
>r over r> grid-positions >r grid-positions r>
pair-up r> [ set-rect-loc ] do-grid ;
pair-up r> [ (>>loc) ] do-grid ;
: resize-grid ( grid horiz vert -- )
pick fill?>> [

4
basis/ui/gadgets/incremental/incremental.factor
View File

@ -37,8 +37,8 @@ M: incremental pref-dim*
[ next-cursor ] keep (>>cursor) ;
: incremental-loc ( gadget incremental -- )
dup cursor>> swap orientation>> v*
swap set-rect-loc ;
[ cursor>> ] [ orientation>> ] bi v*
>>loc drop ;
: prefer-incremental ( gadget -- )
dup forget-pref-dim dup pref-dim >>dim drop ;

2
basis/ui/gadgets/labels/labels.factor
View File

@ -43,7 +43,7 @@ M: label gadget-text* label-string % ;
TUPLE: label-control < label ;
M: label-control model-changed
swap model-value over set-label-string relayout ;
swap value>> over set-label-string relayout ;
: <label-control> ( model -- gadget )
"" label-control new-label

6
basis/ui/gadgets/lib/lib.factor
View File

@ -1,6 +1,8 @@
USING: ui.backend ui.gadgets.worlds ;
USING: accessors kernel ui.backend ui.gadgets.worlds ;
IN: ui.gadgets.lib
: find-gl-context ( gadget -- ) find-world world-handle select-gl-context ;
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup [ handle>> select-gl-context ] [ no-world-found ] if ;

2
basis/ui/gadgets/menus/menus.factor
View File

@ -14,7 +14,7 @@ TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
>r over menu-loc over set-rect-loc r>
>r over menu-loc >>loc r>
[ swap add-gadget drop ] keep ;
M: menu-glass layout* gadget-child prefer ;

2
basis/ui/gadgets/packs/packs.factor
View File

@ -32,7 +32,7 @@ TUPLE: pack < gadget
: pack-layout ( pack sizes -- )
round-dims over children>>
>r dupd packed-dims r> 2dup [ (>>dim) ] 2each
>r packed-locs r> [ set-rect-loc ] 2each ;
>r packed-locs r> [ (>>loc) ] 2each ;
: <pack> ( orientation -- pack )
pack new-gadget

6
basis/ui/gadgets/panes/panes-tests.factor
View File

@ -1,11 +1,11 @@
IN: ui.gadgets.panes.tests
USING: alien ui.gadgets.panes ui.gadgets namespaces
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting tools.test.ui models math summary
inspector ;
inspector accessors ;
IN: ui.gadgets.panes.tests
: #children "pane" get gadget-children length ;
: #children "pane" get children>> length ;
[ ] [ <pane> "pane" set ] unit-test

2
basis/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -69,4 +69,4 @@ M: paragraph pref-dim*
[ 2drop ] do-wrap ;
M: paragraph layout*
[ swap dup prefer set-rect-loc ] do-wrap drop ;
[ swap dup prefer (>>loc) ] do-wrap drop ;

6
basis/ui/gadgets/presentations/presentations-tests.factor
View File

@ -1,7 +1,7 @@
IN: ui.gadgets.presentations.tests
USING: math ui.gadgets.presentations ui.gadgets tools.test
prettyprint ui.gadgets.buttons io io.streams.string kernel
classes.tuple ;
classes.tuple accessors ;
IN: ui.gadgets.presentations.tests
[ t ] [
"Hi" \ + <presentation> gadget?
@ -9,6 +9,6 @@ classes.tuple ;
[ "+" ] [
[
\ + f \ pprint <command-button> dup button-quot call
\ + f \ pprint <command-button> dup quot>> call
] with-string-writer
] unit-test

36
basis/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -1,9 +1,9 @@
IN: ui.gadgets.scrollers.tests
USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences
tools.test.ui math.geometry.rect ;
tools.test.ui math.geometry.rect accessors ;
IN: ui.gadgets.scrollers.tests
[ ] [
<gadget> "g" set
@ -12,11 +12,11 @@ tools.test.ui math.geometry.rect ;
[ { 100 200 } ] [
{ 100 200 } "g" get scroll>rect
"s" get scroller-follows rect-loc
"s" get follows>> rect-loc
] unit-test
[ ] [ "s" get scroll>bottom ] unit-test
[ t ] [ "s" get scroller-follows ] unit-test
[ t ] [ "s" get follows>> ] unit-test
[ ] [
<gadget> dup "g" set
@ -25,46 +25,46 @@ tools.test.ui math.geometry.rect ;
] unit-test
"v" get [
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "v" get model>> range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
] with-grafted-gadget
[ ] [
<gadget> { 100 100 } over set-rect-dim
<gadget> { 100 100 } >>dim
dup "g" set <scroller> "s" set
] unit-test
[ ] [ { 50 50 } "s" get set-rect-dim ] unit-test
[ ] [ "s" get { 50 50 } >>dim drop ] unit-test
[ ] [ "s" get layout ] unit-test
"s" get [
[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
[ { 34 34 } ] [ "s" get viewport>> rect-dim ] unit-test
[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
[ { 106 106 } ] [ "s" get viewport>> viewport-dim ] unit-test
[ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
[ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
[ { 106 106 } ] [ "s" get model>> range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get model>> range-value ] unit-test
[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
] with-grafted-gadget
<gadget> { 600 400 } over set-rect-dim "g1" set
<gadget> { 600 10 } over set-rect-dim "g2" set
<gadget> { 600 400 } >>dim "g1" set
<gadget> { 600 10 } >>dim "g2" set
"g2" get "g1" get swap add-gadget drop
"g1" get <scroller>
{ 300 300 } over set-rect-dim
{ 300 300 } >>dim
dup layout
"s" set
@ -80,9 +80,9 @@ dup layout
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
[ t ] [ "l" get dup find-scroller viewport>> swap child? ] unit-test
[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
[ f ] [ "s" get viewport>> find-scroller* ] unit-test
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test

2
basis/ui/gadgets/sliders/sliders.factor
View File

@ -104,7 +104,7 @@ elevator H{
: layout-thumb-loc ( slider -- )
dup thumb-loc (layout-thumb)
>r [ floor ] map r> set-rect-loc ;
>r [ floor ] map r> (>>loc) ;
: layout-thumb-dim ( slider -- )
dup dup thumb-dim (layout-thumb) >r

2
basis/ui/gadgets/status-bar/status-bar-docs.factor
View File

@ -5,4 +5,4 @@ IN: ui.gadgets.status-bar
HELP: <status-bar>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
{ $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;

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