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-08-31 21:25:45 -05:00
parent 683993c947 88aa1def35
commit 416ea757e8
104 changed files with 941 additions and 602 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/arrays/arrays.factor
View File

@ -10,7 +10,7 @@ M: array c-type ;
M: array heap-size unclip heap-size [ * ] reduce ;
M: array c-type-align first c-type c-type-align ;
M: array c-type-align first c-type-align ;
M: array c-type-stack-align? drop f ;

67
basis/alien/c-types/c-types.factor
View File

@ -37,6 +37,7 @@ ERROR: no-c-type name ;
dup string? [ (c-type) ] when
] when ;
! C type protocol
GENERIC: c-type ( name -- type ) foldable
: resolve-pointer-type ( name -- name )
@ -62,6 +63,60 @@ M: string c-type ( name -- type )
] ?if
] if ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
M: string c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: c-type c-type-boxer-quot boxer-quot>> ;
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
M: string c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: c-type c-type-unboxer-quot unboxer-quot>> ;
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-reg-class ( name -- reg-class )
M: c-type c-type-reg-class reg-class>> ;
M: string c-type-reg-class c-type c-type-reg-class ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
M: string c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
M: string c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: c-type c-type-align align>> ;
M: string c-type-align c-type c-type-align ;
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
dup c-type-reg-class
swap c-type-boxer [ "No boxer" throw ] unless*
@ -72,10 +127,6 @@ M: string c-type ( name -- type )
swap c-type-unboxer [ "No unboxer" throw ] unless*
%unbox ;
M: string c-type-align c-type c-type-align ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
GENERIC: box-parameter ( n ctype -- )
M: c-type box-parameter c-type-box ;
@ -107,25 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
M: c-type heap-size c-type-size ;
M: c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
M: c-type stack-size c-type-size ;
M: c-type stack-size size>> ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ;
: c-getter ( name -- quot )
c-type c-type-getter [
c-type-getter [
[ "Cannot read struct fields with type" throw ]
] unless* ;
: c-setter ( name -- quot )
c-type c-type-setter [
c-type-setter [
[ "Cannot write struct fields with type" throw ]
] unless* ;

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

@ -1,5 +1,5 @@
IN: alien.structs
USING: alien.c-types strings help.markup help.syntax
USING: accessors alien.c-types strings help.markup help.syntax
alien.syntax sequences io arrays slots.deprecated
kernel words slots assocs namespaces accessors ;
@ -67,7 +67,7 @@ M: word slot-specs "slots" word-prop ;
first dup "writing" word-prop [ slot-specs ] keep
$spec-writer ;
M: string slot-specs c-type struct-type-fields ;
M: string slot-specs c-type fields>> ;
M: array ($instance) first ($instance) " array" write ;

2
basis/alien/structs/structs-tests.factor
View File

@ -7,7 +7,7 @@ C-STRUCT: bar
{ { "int" 8 } "y" } ;
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
C-STRUCT: align-test
{ "int" "x" }

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

@ -6,7 +6,7 @@ slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )
c-type c-type-align align ;
c-type-align align ;
: struct-offsets ( specs -- size )
0 [
@ -24,7 +24,7 @@ IN: alien.structs
[ reader>> ]
[
class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
[ c-getter ] [ c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
@ -44,9 +44,9 @@ IN: alien.structs
TUPLE: struct-type size align fields ;
M: struct-type heap-size struct-type-size ;
M: struct-type heap-size size>> ;
M: struct-type c-type-align struct-type-align ;
M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;

4
basis/bootstrap/stage2.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors init command-line namespaces words debugger io
USING: accessors init namespaces words io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
math.parser generic sets ;
math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time

172
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 ;
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 timestamps 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 timestamps with the " { $link <=> } " word." } ;
{ timestamp duration } related-words
@ -28,4 +28,168 @@ HELP: <date>
HELP: month-names
{ $values { "array" array } }
{ $description "Returns an array with the English names of all the months. January has a index of 1 instead of 0." } ;
{ $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
HELP: month-name
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
{ $values { "array" array } }
{ $description "Returns an array with the English abbreviated names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
HELP: month-abbreviation
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: day-names
{ $values { "array" array } }
{ $description "Returns an array with the English names of the days of the week." } ;
HELP: day-name
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
{ $values { "array" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3
{ $values { "array" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is three characters long." } ;
{
day-name day-names
day-abbreviation2 day-abbreviations2
day-abbreviation3 day-abbreviations3
} related-words
HELP: average-month
{ $values { "ratio" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
{ $values { "integer" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
{ $values { "ratio" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
{ $values { "ratio" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
{ $values { "ratio" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
{ $values { "integer" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
{ $warning "Not valid before year -4800 BCE." } ;
HELP: julian-day-number>date
{ $values { "n" integer } { "year" integer } { "month" integer } { "day" integer } }
{ $description "Converts from a Julian day number back to a year, month, and day." } ;
{ julian-day-number julian-day-number>date } related-words
HELP: >date<
{ $values { "timestamp" timestamp } { "year" integer } { "month" integer } { "day" integer } }
{ $description "Explodes a " { $snippet "timestamp" } " into its year, month, and day components." }
{ $examples { $example "USING: arrays calendar prettyprint ;"
"2010 8 24 <date> >date< 3array ."
"{ 2010 8 24 }"
}
} ;
HELP: >time<
{ $values { "timestamp" timestamp } { "hour" integer } { "minute" integer } { "second" integer } }
{ $description "Explodes a " { $snippet "timestamp" } " into its hour, minute, and second components." }
{ $examples { $example "USING: arrays calendar prettyprint ;"
"now noon >time< 3array ."
"{ 12 0 0 }"
}
} ;
{ >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 } ;
HELP: months
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: days
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: weeks
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: hours
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: minutes
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: seconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: milliseconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
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 year <=> ."
"+eq+"
}
{ $example "USING: accessors calendar math.order prettyprint ;"
"2010 1 1 <date> 3 days time+ day>> ."
"4"
}
} ;

61
basis/calendar/calendar.factor
View File

@ -57,7 +57,7 @@ PRIVATE>
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
} ;
: month-abbreviation ( n -- array )
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
: day-names ( -- array )
@ -116,15 +116,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 ;
MEMO: 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 +218,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 +236,8 @@ M: duration time+
2drop <duration>
] if ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar
: dt>years ( duration -- x )
#! Uses average month/year length since duration loses calendar
#! data
0 swap
{
@ -251,12 +251,12 @@ M: duration time+
M: duration <=> [ dt>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 * ;
: 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 * ;
GENERIC: time- ( time1 time2 -- time )
@ -296,7 +296,7 @@ M: timestamp time-
} 2cleave <duration>
] if ;
: before ( dt -- -dt )
: before ( duration -- -duration )
-1 time* ;
M: duration time-
@ -324,8 +324,8 @@ MEMO: unix-1970 ( -- timestamp )
: now ( -- timestamp ) gmt >local-time ;
: hence ( dt -- timestamp ) now swap time+ ;
: ago ( dt -- timestamp ) now swap time- ;
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
@ -377,23 +377,24 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: friday ( timestamp -- timestamp ) 5 day-this-week ;
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
: beginning-of-day ( timestamp -- new-timestamp )
clone
0 >>hour
0 >>minute
0 >>second ; inline
: midnight ( timestamp -- new-timestamp )
clone 0 >>hour 0 >>minute 0 >>second ; inline
: noon ( timestamp -- new-timestamp )
midnight 12 >>hour ; inline
: beginning-of-month ( timestamp -- new-timestamp )
beginning-of-day 1 >>day ;
midnight 1 >>day ;
: beginning-of-week ( timestamp -- new-timestamp )
beginning-of-day sunday ;
midnight sunday ;
: beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 >>month ;
: time-since-midnight ( timestamp -- duration )
dup beginning-of-day time- ;
dup midnight time- ;
M: timestamp sleep-until timestamp>millis sleep-until ;

23
basis/cocoa/views/views.factor
View File

@ -21,6 +21,10 @@ IN: cocoa.views
: NSOpenGLPFASampleBuffers 55 ;
: NSOpenGLPFASamples 56 ;
: NSOpenGLPFAAuxDepthStencil 57 ;
: NSOpenGLPFAColorFloat 58 ;
: NSOpenGLPFAMultisample 59 ;
: NSOpenGLPFASupersample 60 ;
: NSOpenGLPFASampleAlpha 61 ;
: NSOpenGLPFARendererID 70 ;
: NSOpenGLPFASingleRenderer 71 ;
: NSOpenGLPFANoRecovery 72 ;
@ -34,25 +38,36 @@ IN: cocoa.views
: NSOpenGLPFACompliant 83 ;
: NSOpenGLPFAScreenMask 84 ;
: NSOpenGLPFAPixelBuffer 90 ;
: NSOpenGLPFAAllowOfflineRenderers 96 ;
: NSOpenGLPFAVirtualScreenCount 128 ;
: kCGLRendererGenericFloatID HEX: 00020400 ;
<PRIVATE
SYMBOL: +software-renderer+
SYMBOL: +multisample+
PRIVATE>
: with-software-renderer ( quot -- )
t +software-renderer+ set
[ f +software-renderer+ set ]
[ ] cleanup ; inline
t +software-renderer+ pick with-variable ; inline
: with-multisample ( quot -- )
t +multisample+ pick with-variable ; inline
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [ NSOpenGLPFARobust , ] when
+software-renderer+ get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
] when
+multisample+ get [
NSOpenGLPFASupersample ,
NSOpenGLPFASampleBuffers , 1 ,
NSOpenGLPFASamples , 8 ,
] when
0 ,
] { } make >c-int-array
-> initWithAttributes:

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

@ -69,23 +69,21 @@ TUPLE: ds-loc n class ;
: <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
M: ds-loc set-operand-class set-ds-loc-class ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> ( n -- loc ) f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc move-spec drop loc ;
INSTANCE: loc value
@ -106,12 +104,12 @@ M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-vregs* vreg>> live-vregs* ;
M: cached live-loc? cached-loc live-loc? ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
M: cached lazy-store
2dup cached-loc live-loc?
2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
INSTANCE: cached value
@ -121,48 +119,48 @@ TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
M: tagged operand-class* tagged-class ;
M: tagged v>operand vreg>> v>operand ;
M: tagged set-operand-class (>>class) ;
M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
M: tagged live-vregs* tagged-vreg , ;
M: tagged live-vregs* vreg>> , ;
INSTANCE: tagged value
! Unboxed alien pointers
TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
M: unboxed-alien v>operand vreg>> v>operand ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
M: unboxed-alien live-vregs* vreg>> , ;
INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
M: unboxed-byte-array v>operand vreg>> v>operand ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
M: unboxed-byte-array live-vregs* vreg>> , ;
INSTANCE: unboxed-byte-array value
TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f
M: unboxed-f v>operand unboxed-f-vreg v>operand ;
M: unboxed-f v>operand vreg>> v>operand ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-f live-vregs* unboxed-f-vreg , ;
M: unboxed-f live-vregs* vreg>> , ;
INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
M: unboxed-c-ptr v>operand vreg>> v>operand ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
M: unboxed-c-ptr live-vregs* vreg>> , ;
INSTANCE: unboxed-c-ptr value

30
basis/compiler/tests/folding.factor Normal file
View File

@ -0,0 +1,30 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
! Calls to generic words were not folded away.
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: math arrays ;
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
"> eval
] unit-test
[ ] [
<"
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
"> eval
] unit-test
[ t ] [
"fold-test" "compiler.tests.folding" lookup execute
"fold-test" "compiler.tests.folding" lookup execute
eq?
] unit-test

3
basis/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -103,6 +103,9 @@ DEFER: copy-value
[ [ allocation copy-allocation ] dip record-allocation ]
2bi ;
: copy-values ( from to -- )
[ copy-value ] 2each ;
: copy-slot-value ( out slot# in -- )
allocation {
{ [ dup not ] [ 3drop ] }

24
basis/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -42,24 +42,26 @@ IN: compiler.tree.escape-analysis.recursive
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
[ label>> return>> in-d>> introduce-values ]
[
child>>
[ first out-d>> introduce-values ]
[ first analyze-recursive-phi ]
[ (escape-analysis) ]
tri
] until-fixed-point ;
[
child>>
[ first out-d>> introduce-values ]
[ first analyze-recursive-phi ]
[ (escape-analysis) ]
tri
] until-fixed-point
] bi ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
#! Handled by #recursive
drop ;
: return-allocations ( node -- allocations )
label>> return>> node-input-allocations ;
M: #call-recursive escape-analysis* ( #call-label -- )
[ ] [ return-allocations ] [ node-output-allocations ] tri
[ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
[ ] [ label>> return>> ] [ node-output-allocations ] tri
[ [ node-input-allocations ] dip check-fixed-point ]
[ drop swap [ in-d>> ] [ out-d>> ] bi* copy-values ]
3bi ;
M: #return-recursive escape-analysis* ( #return-recursive -- )
[ call-next-method ]

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

@ -13,7 +13,7 @@ IN: compiler.tree.escape-analysis.simple
M: #terminate escape-analysis* drop ;
M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
M: #renaming escape-analysis* inputs/outputs copy-values ;
M: #introduce escape-analysis* out-d>> unknown-allocations ;

18
basis/compiler/tree/finalization/finalization.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences
compiler.tree compiler.tree.combinators ;
IN: compiler.tree.finalization
GENERIC: finalize* ( node -- nodes )
M: #copy finalize* drop f ;
M: #shuffle finalize*
dup shuffle-effect
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
M: node finalize* ;
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

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

@ -204,5 +204,6 @@ M: node normalize* ;
H{ } clone rename-map set
dup [ collect-label-info ] each-node
dup count-introductions make-values
[ (normalize) ] [ nip #introduce ] 2bi prefix
[ (normalize) ] [ nip ] 2bi
dup empty? [ drop ] [ #introduce prefix ] if
rename-node-values ;

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

@ -11,6 +11,7 @@ compiler.tree.strength-reduction
compiler.tree.loop.detection
compiler.tree.loop.inversion
compiler.tree.branch-fusion
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
@ -25,6 +26,7 @@ IN: compiler.tree.optimizer
unbox-tuples
compute-def-use
remove-dead-code
finalize
! strength-reduce
! USE: kernel
! compute-def-use

6
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
@ -84,7 +82,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 ;

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

@ -17,11 +17,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 +66,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 +120,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 +158,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 +178,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 +196,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 +206,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
] "outputs" set-word-prop
{
{ >fixnum fixnum }
@ -226,7 +226,7 @@ generic-comparison-ops [
interval-intersect
] 2bi
<class/interval-info>
] +outputs+ set-word-prop
] "outputs" set-word-prop
] assoc-each
{
@ -250,36 +250,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> } [
[
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 +292,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 -- )

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

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

@ -46,3 +46,10 @@ TUPLE: empty-tuple ;
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
TUPLE: box { i read-only } ;
: box-test ( m -- n )
dup box-test i>> swap box-test drop box boa ; inline recursive
[ ] [ [ T{ box f 34 } box-test i>> ] test-unboxing ] unit-test

3
basis/cpu/ppc/allot/allot.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
generator generator.registers generator.fixup system layouts
compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts
cpu.architecture alien ;
IN: cpu.ppc.allot

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

@ -1,10 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
kernel kernel.private math memory namespaces sequences words
assocs compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts classes words.private
alien combinators compiler.constants math.order ;
USING: accessors alien.c-types cpu.ppc.assembler
cpu.architecture generic kernel kernel.private math memory
namespaces sequences words assocs compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts classes words.private alien combinators
compiler.constants math.order ;
IN: cpu.ppc.architecture
! PowerPC register assignments
@ -65,8 +66,8 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
GENERIC: loc>operand ( loc -- reg n )
M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ;
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: ds-loc loc>operand n>> cells neg ds-reg swap ;
M: rs-loc loc>operand n>> cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;

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

@ -5,9 +5,10 @@ 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 generator.fixup sequences.private
sbufs vectors system layouts math.floats.private classes
slots.private combinators compiler.constants ;
compiler.generator.registers compiler.generator.fixup
sequences.private sbufs vectors system layouts
math.floats.private classes slots.private combinators
compiler.constants ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
@ -436,44 +437,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

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

@ -1,14 +1,15 @@
USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
namespaces alien.c-types kernel system combinators ;
USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
cpu.architecture namespaces alien.c-types kernel system
combinators ;
{
{ [ os macosx? ] [
4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align
4 "double" c-type set-c-type-align
4 "longlong" c-type (>>align)
4 "ulonglong" c-type (>>align)
4 "double" c-type (>>align)
] }
{ [ os linux? ] [
t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align?
t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?)
] }
} cond

6
basis/cpu/x86/32/32.factor
View File

@ -259,9 +259,9 @@ M: x86.32 %cleanup ( alien-node -- )
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
os windows? [
cell "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align
4 "double" c-type set-c-type-align
cell "longlong" c-type (>>align)
cell "ulonglong" c-type (>>align)
4 "double" c-type (>>align)
] unless
: (sse2?) ( -- ? ) "Intrinsic" throw ;

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

@ -174,10 +174,10 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type set-c-type-reg-class >>
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
fields>> [
[ class>> ] [ offset>> ] bi 2array
] map ;

6
basis/cpu/x86/architecture/architecture.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays cpu.x86.assembler
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
@ -16,8 +16,8 @@ HOOK: stack-save-reg cpu ( -- reg )
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
M: rs-loc v>operand n>> rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;

10
basis/debugger/debugger.factor
View File

@ -207,7 +207,7 @@ M: no-case summary
M: slice-error error.
"Cannot create slice because " write
slice-error-reason print ;
reason>> print ;
M: bounds-error summary drop "Sequence index out of bounds" ;
@ -232,14 +232,14 @@ M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
"Re-definition of " write
redefine-error-def . ;
def>> . ;
M: undefined summary
drop "Calling a deferred word before it has been defined" ;
M: no-compilation-unit error.
"Attempting to define " write
no-compilation-unit-definition pprint
definition>> pprint
" outside of a compilation unit" print ;
M: no-vocab summary
@ -299,9 +299,9 @@ M: string expected>string ;
M: unexpected error.
"Expected " write
dup unexpected-want expected>string write
dup want>> expected>string write
" but got " write
unexpected-got expected>string print ;
got>> expected>string print ;
M: lexer-error error.
[ lexer-dump ] [ error>> error. ] bi ;

10
basis/documents/documents.factor
View File

@ -28,10 +28,10 @@ TUPLE: document < model locs ;
: update-locs ( loc document -- )
locs>> [ set-model ] with each ;
: doc-line ( n document -- string ) model-value nth ;
: doc-line ( n document -- string ) value>> nth ;
: doc-lines ( from to document -- slice )
>r 1+ r> model-value <slice> ;
>r 1+ r> value>> <slice> ;
: start-on-line ( document from line# -- n1 )
>r dup first r> = [ nip second ] [ 2drop 0 ] if ;
@ -99,7 +99,7 @@ TUPLE: document < model locs ;
>r >r >r "" r> r> r> set-doc-range ;
: last-line# ( document -- line )
model-value length 1- ;
value>> length 1- ;
: validate-line ( line document -- line )
last-line# min 0 max ;
@ -117,7 +117,7 @@ TUPLE: document < model locs ;
[ last-line# ] keep line-end ;
: validate-loc ( loc document -- newloc )
over first over model-value length >= [
over first over value>> length >= [
nip doc-end
] [
over first 0 < [
@ -128,7 +128,7 @@ TUPLE: document < model locs ;
] if ;
: doc-string ( document -- str )
model-value "\n" join ;
value>> "\n" join ;
: set-doc-string ( string document -- )
>r string-lines V{ } like r> [ set-model ] keep

22
basis/help/definitions/definitions.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions help help.topics help.syntax
USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint words kernel effects ;
IN: help.definitions
@ -8,30 +8,30 @@ IN: help.definitions
M: link definer drop \ ARTICLE: \ ; ;
M: link where link-name article article-loc ;
M: link where name>> article loc>> ;
M: link set-where link-name article set-article-loc ;
M: link set-where name>> article (>>loc) ;
M: link forget* link-name remove-article ;
M: link forget* name>> remove-article ;
M: link definition article-content ;
M: link synopsis*
dup definer.
dup link-name pprint*
dup name>> pprint*
article-title pprint* ;
M: word-link definer drop \ HELP: \ ; ;
M: word-link where link-name "help-loc" word-prop ;
M: word-link where name>> "help-loc" word-prop ;
M: word-link set-where link-name swap "help-loc" set-word-prop ;
M: word-link set-where name>> swap "help-loc" set-word-prop ;
M: word-link definition link-name "help" word-prop ;
M: word-link definition name>> "help" word-prop ;
M: word-link synopsis*
dup definer.
link-name dup pprint-word
name>> dup pprint-word
stack-effect. ;
M: word-link forget* link-name remove-word-help ;
M: word-link forget* name>> remove-word-help ;

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

@ -131,7 +131,7 @@ M: help-error error.
: run-help-lint ( prefix -- alist )
[
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
articles get keys "group-articles" set
group-articles "vocab-articles" set
child-vocabs
[ dup check-vocab ] { } map>assoc
[ nip empty? not ] assoc-filter

4
basis/help/markup/markup.factor
View File

@ -143,13 +143,13 @@ M: f print-element drop ;
link-style get [ write-object ] with-style ;
: ($link) ( article -- )
[ dup article-name swap >link write-link ] ($span) ;
[ [ article-name ] [ >link ] bi write-link ] ($span) ;
: $link ( element -- )
first ($link) ;
: ($long-link) ( object -- )
dup article-title swap >link write-link ;
[ article-title ] [ >link ] bi write-link ;
: ($subsection) ( element quot -- )
[

7
basis/help/syntax/syntax.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel parser sequences words help help.topics
namespaces vocabs definitions compiler.units ;
USING: accessors arrays kernel parser sequences words help
help.topics namespaces vocabs definitions compiler.units ;
IN: help.syntax
: HELP:
@ -16,7 +16,6 @@ IN: help.syntax
over add-article >link r> remember-definition ; parsing
: ABOUT:
scan-object
in get vocab
dup changed-definition
set-vocab-help ; parsing
scan-object >>help drop ; parsing

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
@ -34,6 +34,6 @@ SYMBOL: foo
] unit-test
[ { "testfile" 2 } ]
[ { "test" 1 } articles get at article-loc ] unit-test
[ { "test" 1 } articles get at loc>> ] unit-test
[ ] [ { "test" 1 } remove-article ] unit-test

6
basis/help/topics/topics.factor
View File

@ -34,6 +34,8 @@ SYMBOL: article-xref
article-xref global [ H{ } assoc-like ] change-at
GENERIC: article-name ( topic -- string )
GENERIC: article-title ( topic -- string )
GENERIC: article-content ( topic -- content )
GENERIC: article-parent ( topic -- parent )
GENERIC: set-article-parent ( parent topic -- )
@ -42,7 +44,9 @@ TUPLE: article title content loc ;
: <article> ( title content -- article )
f \ article boa ;
M: article article-name article-title ;
M: article article-name title>> ;
M: article article-title title>> ;
M: article article-content content>> ;
ERROR: no-article name ;

7
basis/io/mmap/mmap-docs.factor
View File

@ -5,8 +5,8 @@ IN: io.mmap
HELP: mapped-file
{ $class-description "The class of memory-mapped files, opened by " { $link <mapped-file> } " and closed by " { $link close-mapped-file } ". The following two slots are of interest to users:"
{ $list
{ { $link mapped-file-length } " - the length of the mapped file area, in bytes" }
{ { $link mapped-file-address } " - an " { $link alien } " pointing at the file's memory area" }
{ { $snippet "length" } " - the length of the mapped file area, in bytes" }
{ { $snippet "address" } " - an " { $link alien } " pointing at the file's memory area" }
}
} ;
@ -33,8 +33,7 @@ ARTICLE: "io.mmap" "Memory-mapped files"
$nl
"A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
{ $subsection mapped-file-address }
"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl
"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
ABOUT: "io.mmap"

2
basis/io/ports/ports.factor
View File

@ -109,7 +109,7 @@ M: output-port stream-write1
M: output-port stream-write
dup check-disposed
over length over buffer>> buffer-size > [
over length over buffer>> size>> > [
[ buffer>> size>> <groups> ]
[ [ stream-write ] curry ] bi
each

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 ;

0
extra/math/points/points.factor → basis/math/points/points.factor
View File

2
basis/models/compose/compose-docs.factor
View File

@ -20,7 +20,7 @@ $nl
HELP: <compose>
{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." }
{ $examples "See the example in the documentation for " { $link compose } "." } ;
ARTICLE: "models-compose" "Composed models"

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

@ -6,7 +6,7 @@ IN: models.delay
TUPLE: delay < model model timeout alarm ;
: update-delay-model ( delay -- )
[ delay-model model-value ] keep set-model ;
[ model>> value>> ] keep set-model ;
: <delay> ( model timeout -- delay )
f delay new-model
@ -15,7 +15,7 @@ TUPLE: delay < model model timeout alarm ;
[ add-dependency ] keep ;
: cancel-delay ( delay -- )
delay-alarm [ cancel-alarm ] when* ;
alarm>> [ cancel-alarm ] when* ;
: start-delay ( delay -- )
dup

10
basis/models/history/history.factor
View File

@ -14,7 +14,7 @@ TUPLE: history < model back forward ;
reset-history ;
: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
swap value>> dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
@ -22,11 +22,11 @@ TUPLE: history < model back forward ;
[ >r dupd (add-history) r> pop swap set-model ] if ;
: go-back ( history -- )
dup history-forward over history-back go-back/forward ;
dup [ forward>> ] [ back>> ] bi go-back/forward ;
: go-forward ( history -- )
dup history-back over history-forward go-back/forward ;
dup [ back>> ] [ forward>> ] bi go-back/forward ;
: add-history ( history -- )
dup history-forward delete-all
dup history-back (add-history) ;
dup forward>> delete-all
dup back>> (add-history) ;

7
basis/models/models-docs.factor
View File

@ -63,12 +63,7 @@ HELP: set-model
{ $values { "value" object } { "model" model } }
{ $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
{ set-model set-model-value change-model (change-model) } related-words
HELP: set-model-value ( value model -- )
{ $values { "value" object } { "model" model } }
{ $description "Changes the value of a model without notifying any observers registered with " { $link add-connection } "." }
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link set-model } ", which notifies observers." } ;
{ set-model change-model (change-model) } related-words
HELP: change-model
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }

4
basis/multiline/multiline.factor
View File

@ -5,7 +5,7 @@ accessors ;
IN: multiline
: next-line-text ( -- str )
lexer get dup next-line text>> ;
lexer get dup next-line line-text>> ;
: (parse-here) ( -- )
next-line-text [
@ -23,7 +23,7 @@ IN: multiline
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get text>> [
lexer get line-text>> [
2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0

2
basis/peg/parsers/parsers.factor
View File

@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
M: just-parser (compile) ( parser -- quot )
just-parser-p1 compile-parser just-pattern curry ;
p1>> compile-parser just-pattern curry ;
: just ( parser -- parser )
just-parser boa wrap-peg ;

2
basis/prettyprint/backend/backend.factor
View File

@ -105,7 +105,7 @@ M: sbuf pprint*
dup "SBUF\" " "\"" pprint-string ;
M: pathname pprint*
dup pathname-string "P\" " "\"" pprint-string ;
dup string>> "P\" " "\"" pprint-string ;
! Sequences
: nesting-limit? ( -- ? )

2
basis/prettyprint/prettyprint.factor
View File

@ -172,7 +172,7 @@ M: hook-generic synopsis*
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ "combination" word-prop hook-combination-var pprint* ]
[ "combination" word-prop var>> pprint* ]
[ stack-effect. ]
} cleave ;

10
basis/prettyprint/sections/sections.factor
View File

@ -205,7 +205,7 @@ TUPLE: text < section string ;
swap >>style
swap >>string ;
M: text short-section text-string write ;
M: text short-section string>> write ;
M: text long-section short-section ;
@ -291,17 +291,13 @@ SYMBOL: next
: split-groups ( ? -- ) [ t , ] when ;
M: f section-start-group? drop t ;
M: f section-end-group? drop f ;
: split-before ( section -- )
[ section-start-group? prev get section-end-group? and ]
[ start-group?>> prev get [ end-group?>> ] [ t ] if* and ]
[ flow? prev get flow? not and ]
bi or split-groups ;
: split-after ( section -- )
section-end-group? split-groups ;
[ end-group?>> ] [ f ] if* split-groups ;
: group-flow ( seq -- newseq )
[

10
basis/stack-checker/known-words/known-words.factor
View File

@ -173,15 +173,13 @@ do-primitive alien-invoke alien-indirect alien-callback
{ call execute dispatch load-locals get-local drop-locals }
[ t "no-compile" set-word-prop ] each
SYMBOL: +primitive+
: non-inline-word ( word -- )
dup called-dependency depends-on
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }
{ [ dup +primitive+ word-prop ] [ infer-primitive ] }
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
@ -190,7 +188,7 @@ SYMBOL: +primitive+
} cond ;
: define-primitive ( word inputs outputs -- )
[ 2drop t +primitive+ set-word-prop ]
[ 2drop t "primitive" set-word-prop ]
[ drop "input-classes" set-word-prop ]
[ nip "default-output-classes" set-word-prop ]
3tri ;
@ -600,8 +598,6 @@ SYMBOL: +primitive+
\ (set-os-envs) { array } { } define-primitive
\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } define-primitive
\ modify-code-heap { array object } { } define-primitive

11
basis/stack-checker/transforms/transforms.factor
View File

@ -8,9 +8,6 @@ stack-checker.backend stack-checker.state stack-checker.visitor
stack-checker.errors ;
IN: stack-checker.transforms
SYMBOL: +transform-quot+
SYMBOL: +transform-n+
: give-up-transform ( word -- )
dup recursive-label
[ call-recursive-word ]
@ -48,8 +45,8 @@ SYMBOL: +transform-n+
: apply-transform ( word -- )
[ inlined-dependency depends-on ] [
[ ]
[ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ]
[ "transform-quot" word-prop ]
[ "transform-n" word-prop ]
tri
(apply-transform)
] bi ;
@ -64,8 +61,8 @@ SYMBOL: +transform-n+
] bi ;
: define-transform ( word quot n -- )
[ drop +transform-quot+ set-word-prop ]
[ nip +transform-n+ set-word-prop ]
[ drop "transform-quot" set-word-prop ]
[ nip "transform-n" set-word-prop ]
3bi ;
! Combinators

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

@ -85,8 +85,11 @@ IN: tools.deploy.shaker
[
strip-dictionary? [
{
"cannot-infer"
"coercer"
"combination"
"compiled-effect"
"compiled-generic-uses"
"compiled-uses"
"constraints"
"declared-effect"
@ -94,38 +97,52 @@ IN: tools.deploy.shaker
"default-method"
"default-output-classes"
"derived-from"
"identities"
"engines"
"if-intrinsics"
"infer"
"inferred-effect"
"inline"
"inlined-block"
"input-classes"
"interval"
"intrinsics"
"lambda"
"loc"
"local-reader"
"local-reader?"
"local-writer"
"local-writer?"
"local?"
"macro"
"members"
"methods"
"memo-quot"
"method-class"
"method-generic"
"combination"
"cannot-infer"
"methods"
"no-compile"
"optimizer-hooks"
"output-classes"
"outputs"
"participants"
"predicate"
"predicate-definition"
"predicating"
"tuple-dispatch-generic"
"slots"
"reader"
"reading"
"recursive"
"shuffle"
"slot-names"
"slots"
"special"
"specializer"
"step-into"
"step-into?"
"superclass"
"reading"
"writing"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"
"type"
"engines"
"writer"
"writing"
} %
] when
@ -211,6 +228,7 @@ IN: tools.deploy.shaker
classes:update-map
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
compiler.units:recompile-hook
compiler.units:update-tuples-hook
definitions:crossref

16
basis/tools/deploy/test/1/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
{ deploy-random? f }
{ deploy-name "tools.deploy.test.1" }
{ deploy-threads? t }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.1" }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-ui? f }
{ deploy-random? f }
{ deploy-math? t }
{ deploy-compiler? t }
{ deploy-reflection 2 }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
}

14
basis/tools/deploy/test/2/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-compiler? t }
{ deploy-reflection 2 }
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-c-types? f }
{ deploy-random? f }
{ "stop-after-last-window?" t }
{ deploy-name "tools.deploy.test.2" }
{ deploy-io 2 }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

18
basis/tools/deploy/test/3/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
{ deploy-random? f }
{ deploy-name "tools.deploy.test.3" }
{ deploy-threads? t }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-ui? f }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.3" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/4/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-reflection 1 }
{ deploy-io 2 }
{ deploy-c-types? f }
{ deploy-random? f }
{ deploy-ui? f }
{ deploy-name "tools.deploy.test.4" }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.4" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/5/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-reflection 1 }
{ deploy-io 3 }
{ deploy-c-types? f }
{ deploy-random? f }
{ deploy-ui? f }
{ deploy-name "tools.deploy.test.5" }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.5" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

12
basis/tools/vocabs/browser/browser.factor
View File

@ -181,12 +181,12 @@ M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ;
M: vocab-tag article-title
vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
name>> "Vocabularies tagged ``" swap "''" 3append ;
M: vocab-tag article-name vocab-tag-name ;
M: vocab-tag article-name name>> ;
M: vocab-tag article-content
\ $tagged-vocabs swap vocab-tag-name 2array ;
\ $tagged-vocabs swap name>> 2array ;
M: vocab-tag article-parent drop "vocab-index" ;
@ -195,12 +195,12 @@ M: vocab-tag summary article-title ;
M: vocab-author >link ;
M: vocab-author article-title
vocab-author-name "Vocabularies by " prepend ;
name>> "Vocabularies by " prepend ;
M: vocab-author article-name vocab-author-name ;
M: vocab-author article-name name>> ;
M: vocab-author article-content
\ $authored-vocabs swap vocab-author-name 2array ;
\ $authored-vocabs swap name>> 2array ;
M: vocab-author article-parent drop "vocab-index" ;

2
basis/tools/walker/debug/debug.factor
View File

@ -27,5 +27,5 @@ IN: tools.walker.debug
p ?promise
variables>> walker-continuation swap at
model-value data>>
value>> data>>
] ;

2
basis/tools/walker/walker.factor
View File

@ -163,7 +163,7 @@ SYMBOL: +stopped+
] change-frame ;
: status ( -- symbol )
walker-status tget model-value ;
walker-status tget value>> ;
: set-status ( symbol -- )
walker-status tget set-model ;

2
basis/ui/freetype/freetype.factor
View File

@ -184,7 +184,7 @@ M: freetype-renderer string-height ( open-font string -- h )
: draw-char ( open-font sprites char loc -- )
GL_MODELVIEW [
0 0 glTranslated
char-sprite sprite-dlist glCallList
char-sprite dlist>> glCallList
] do-matrix ;
: char-widths ( open-font string -- widths )

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

@ -55,9 +55,9 @@ M: editor ungraft*
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
: editor-caret* ( editor -- loc ) caret>> model-value ;
: editor-caret* ( editor -- loc ) caret>> value>> ;
: editor-mark* ( editor -- loc ) mark>> model-value ;
: editor-mark* ( editor -- loc ) mark>> value>> ;
: set-caret ( loc editor -- )
[ model>> validate-loc ] keep
@ -501,7 +501,7 @@ TUPLE: field < wrapper field-model editor ;
swap >>field-model ;
M: field graft*
[ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
[ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
[ dup editor>> model>> add-connection ]
bi ;

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

@ -50,7 +50,7 @@ M: gadget model-changed 2drop ;
dup model>> dup [ 2dup remove-connection ] when 2drop ;
: control-value ( control -- value )
model>> model-value ;
model>> value>> ;
: set-control-value ( value control -- )
model>> set-model ;

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

@ -8,4 +8,4 @@ TUPLE: handler < wrapper table ;
: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture ( gesture gadget -- ? )
over table>> at dup [ call f ] [ 2drop t ] if ;
tuck table>> at dup [ call f ] [ 2drop t ] if ;

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

@ -41,7 +41,7 @@ M: incremental pref-dim*
swap set-rect-loc ;
: prefer-incremental ( gadget -- )
dup forget-pref-dim dup pref-dim swap set-rect-dim ;
dup forget-pref-dim dup pref-dim >>dim drop ;
: add-incremental ( gadget incremental -- )
not-in-layout

2
basis/ui/render/render.factor
View File

@ -138,7 +138,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget )
dup max-dim
>r <polygon> <gadget> r> over set-rect-dim
>r <polygon> <gadget> r> >>dim
[ (>>interior) ] keep ;
! Font rendering

6
basis/ui/tools/browser/browser.factor
View File

@ -39,17 +39,17 @@ M: browser-gadget ungraft*
: showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep
[ >r dup word-link? [ link-name ] when r> key? ] 2keep
[ >r dup word-link? [ name>> ] when r> key? ] 2keep
>r dup vocab-link? [ vocab ] when r> key?
or or ;
M: browser-gadget definitions-changed ( assoc browser -- )
history>>
dup model-value rot showing-definition?
dup value>> rot showing-definition?
[ notify-connections ] [ drop ] if ;
: help-action ( browser-gadget -- link )
history>> model-value >link ;
history>> value>> >link ;
: com-follow ( link -- ) browser-gadget call-tool ;

2
basis/ui/tools/debugger/debugger.factor
View File

@ -11,7 +11,7 @@ USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget )
[ restart-name ] rot <model> <list> ;
[ name>> ] rot <model> <list> ;
TUPLE: debugger < track restarts ;

4
basis/ui/tools/search/search.factor
View File

@ -118,7 +118,7 @@ M: live-search pref-dim* drop { 400 200 } ;
: <source-file-search> ( string files -- gadget )
source-file-candidates
f [ pathname-string ] <live-search> ;
f [ string>> ] <live-search> ;
: all-source-files ( -- seq )
source-files get keys natural-sort ;
@ -146,7 +146,7 @@ M: live-search pref-dim* drop { 400 200 } ;
: <history-search> ( string seq -- gadget )
history-candidates
f [ input-string ] <live-search> ;
f [ string>> ] <live-search> ;
: listener-history ( listener -- seq )
listener-gadget-input interactor-history <reversed> ;

8
basis/ui/tools/traceback/traceback.factor
View File

@ -9,15 +9,15 @@ USING: accessors continuations kernel models namespaces
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
[ [ continuation-call callstack. ] when* ]
[ [ call>> callstack. ] when* ]
t "Call stack" <labelled-pane> ;
: <datastack-display> ( model -- gadget )
[ [ continuation-data stack. ] when* ]
[ [ data>> stack. ] when* ]
t "Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- gadget )
[ [ continuation-retain stack. ] when* ]
[ [ retain>> stack. ] when* ]
t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget < track ;
@ -39,7 +39,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup <toolbar> f track-add ;
: <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ]
[ [ name>> namestack. ] when* ]
<pane-control> ;
: <variables-gadget> ( model -- gadget )

4
basis/ui/tools/walker/walker.factor
View File

@ -41,7 +41,7 @@ M: walker-gadget focusable-child*
: walker-state-string ( status thread -- string )
[
"Thread: " %
dup thread-name %
dup name>> %
" (" %
swap {
{ +stopped+ "Stopped" }
@ -92,7 +92,7 @@ walker-gadget "toolbar" f {
[ swap walker-for-thread? ] curry find-window ;
: walker-window ( status continuation thread -- )
[ <walker-gadget> ] [ thread-name ] bi open-status-window ;
[ <walker-gadget> ] [ name>> ] bi open-status-window ;
[
dup find-walker-window dup

2
core/assocs/assocs.factor
View File

@ -210,7 +210,7 @@ M: enum at*
M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ;
M: enum delete-at seq>> delete-nth ;
M: enum >alist ( enum -- alist )
seq>> [ length ] keep zip ;

13
core/classes/mixin/mixin.factor
View File

@ -78,8 +78,8 @@ TUPLE: mixin-instance loc class mixin ;
M: mixin-instance equal?
{
{ [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
{ [ 2dup [ class>> ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin>> ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ;
@ -91,15 +91,14 @@ M: mixin-instance hashcode*
swap >>mixin
swap >>class ;
M: mixin-instance where mixin-instance-loc ;
M: mixin-instance where loc>> ;
M: mixin-instance set-where set-mixin-instance-loc ;
M: mixin-instance set-where (>>loc) ;
M: mixin-instance definer drop \ INSTANCE: f ;
M: mixin-instance definition drop f ;
M: mixin-instance forget*
dup mixin-instance-class
swap mixin-instance-mixin dup mixin-class?
[ remove-mixin-instance ] [ 2drop ] if ;
[ class>> ] [ mixin>> ] bi
dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;

17
core/compiler/units/units.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math.order classes classes.algebra ;
math math.order classes classes.algebra ;
IN: compiler.units
SYMBOL: old-definitions
@ -73,11 +73,20 @@ GENERIC: definitions-changed ( assoc obj -- )
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: dependency>= ( how1 how2 -- ? )
[
{
called-dependency
flushed-dependency
inlined-dependency
} index
] bi@ >= ;
: strongest-dependency ( how1 how2 -- how )
[ called-dependency or ] bi@ max ;
[ called-dependency or ] bi@ [ dependency>= ] most ;
: weakest-dependency ( how1 how2 -- how )
[ inlined-dependency or ] bi@ min ;
[ inlined-dependency or ] bi@ [ dependency>= not ] most ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
@ -89,7 +98,7 @@ SYMBOL: update-tuples-hook
#! don't have to recompile words that folded this away.
[ compiled-usage ]
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
[ after=? nip ] curry assoc-filter ;
[ dependency>= nip ] curry assoc-filter ;
: compiled-usages ( assoc -- assocs )
[ drop word? ] assoc-filter

2
core/continuations/continuations.factor
View File

@ -178,7 +178,7 @@ M: condition compute-restarts
[ error>> compute-restarts ]
[
[ restarts>> ]
[ condition-continuation [ <restart> ] curry ] bi
[ continuation>> [ <restart> ] curry ] bi
{ } assoc>map
] bi append ;

20
core/definitions/definitions.factor
View File

@ -5,23 +5,9 @@ USING: kernel sequences namespaces assocs graphs math math.order ;
ERROR: no-compilation-unit definition ;
SINGLETON: inlined-dependency
SINGLETON: flushed-dependency
SINGLETON: called-dependency
UNION: dependency
inlined-dependency
flushed-dependency
called-dependency ;
M: dependency <=>
[
{
called-dependency
flushed-dependency
inlined-dependency
} index
] bi@ <=> ;
SYMBOL: inlined-dependency
SYMBOL: flushed-dependency
SYMBOL: called-dependency
SYMBOL: changed-definitions

4
core/io/encodings/encodings.factor
View File

@ -130,9 +130,9 @@ M: encoder stream-write1
M: encoder stream-write
>encoder< decoder-write ;
M: encoder dispose encoder-stream dispose ;
M: encoder dispose stream>> dispose ;
M: encoder stream-flush encoder-stream stream-flush ;
M: encoder stream-flush stream>> stream-flush ;
INSTANCE: encoder plain-writer
PRIVATE>

4
core/sorting/sorting-tests.factor
View File

@ -1,5 +1,5 @@
USING: sorting sequences kernel math math.order random
tools.test vectors sets ;
tools.test vectors sets vocabs ;
IN: sorting.tests
[ { } ] [ { } natural-sort ] unit-test
@ -24,3 +24,5 @@ unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test
[ ] [ all-words natural-sort drop ] unit-test

4
core/source-files/source-files.factor
View File

@ -56,7 +56,7 @@ ERROR: invalid-source-file-path path ;
] [ 2drop ] if
] assoc-each ;
M: pathname where pathname-string 1 2array ;
M: pathname where string>> 1 2array ;
: forget-source ( path -- )
[
@ -69,7 +69,7 @@ M: pathname where pathname-string 1 2array ;
bi ;
M: pathname forget*
pathname-string forget-source ;
string>> forget-source ;
: rollback-source-file ( file -- )
[

4
core/syntax/syntax.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays byte-vectors
USING: accessors alien arrays byte-arrays byte-vectors
definitions generic hashtables kernel math namespaces parser
lexer sequences strings strings.parser sbufs vectors
words quotations io assocs splitting classes.tuple
@ -193,7 +193,7 @@ IN: bootstrap.syntax
"))" parse-effect parsed
] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"MAIN:" [ scan-word in get vocab (>>main) ] define-syntax
"<<" [
[

59
core/vocabs/vocabs.factor
View File

@ -16,44 +16,78 @@ source-loaded? docs-loaded? ;
swap >>name
H{ } clone >>words ;
GENERIC: vocab-name ( vocab-spec -- name )
GENERIC: vocab ( vocab-spec -- vocab )
M: vocab vocab ;
M: object vocab ( name -- vocab ) vocab-name dictionary get at ;
M: vocab vocab-name name>> ;
M: string vocab-name ;
GENERIC: vocab-words ( vocab-spec -- words )
M: vocab vocab-words words>> ;
M: object vocab-words vocab vocab-words ;
M: f vocab-words ;
GENERIC: vocab-help ( vocab-spec -- help )
M: vocab vocab-help help>> ;
M: object vocab-help vocab vocab-help ;
M: f vocab-help ;
GENERIC: vocab-main ( vocab-spec -- main )
M: vocab vocab-main main>> ;
M: object vocab-main vocab vocab-main ;
M: f vocab-main ;
GENERIC: vocab-source-loaded? ( vocab-spec -- ? )
M: vocab vocab-source-loaded? source-loaded?>> ;
M: object vocab-source-loaded?
vocab vocab-source-loaded? ;
M: f vocab-source-loaded? ;
GENERIC: set-vocab-source-loaded? ( ? vocab-spec -- )
M: vocab set-vocab-source-loaded? (>>source-loaded?) ;
M: object set-vocab-source-loaded?
vocab set-vocab-source-loaded? ;
M: f set-vocab-source-loaded? 2drop ;
GENERIC: vocab-docs-loaded? ( vocab-spec -- ? )
M: vocab vocab-docs-loaded? docs-loaded?>> ;
M: object vocab-docs-loaded?
vocab vocab-docs-loaded? ;
M: f vocab-docs-loaded? ;
GENERIC: set-vocab-docs-loaded? ( ? vocab-spec -- )
M: vocab set-vocab-docs-loaded? (>>docs-loaded?) ;
M: object set-vocab-docs-loaded?
vocab set-vocab-docs-loaded? ;
M: f vocab-words ;
M: f vocab-source-loaded? ;
M: f set-vocab-source-loaded? 2drop ;
M: f vocab-docs-loaded? ;
M: f set-vocab-docs-loaded? 2drop ;
M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
@ -90,10 +124,9 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
vocab-link boa ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;
M: vocab-link hashcode* name>> hashcode* ;
M: vocab-link vocab-name vocab-link-name ;
M: vocab-link vocab-name name>> ;
UNION: vocab-spec vocab vocab-link ;

24
extra/asn1/asn1.factor
View File

@ -54,7 +54,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: (set-tag) ( -- )
elements get id>> 31 bitand
dup elements get set-element-tag
dup elements get (>>tag)
31 < [
[ "unsupported tag encoding: #{" %
get-id # "}" %
@ -63,22 +63,22 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: set-tagclass ( -- )
get-id -6 shift tag-classes nth
elements get set-element-tagclass ;
elements get (>>tagclass) ;
: set-encoding ( -- )
get-id HEX: 20 bitand
zero? "primitive" "constructed" ?
elements get set-element-encoding ;
elements get (>>encoding) ;
: set-content-length ( -- )
read1
dup 127 <= [
127 bitand read be>
] unless elements get set-element-contentlength ;
] unless elements get (>>contentlength) ;
: set-newobj ( -- )
elements get contentlength>> read
elements get set-element-newobj ;
elements get (>>newobj) ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
@ -86,7 +86,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
elements get encoding>> swap at
elements get tag>>
swap at [
elements get set-element-objtype
elements get (>>objtype)
] when*
] each ;
@ -96,15 +96,15 @@ SYMBOL: end
: (read-array) ( -- )
elements get id>> [
elements get element-syntax read-ber
elements get syntax>> read-ber
dup end = [ drop ] [ , (read-array) ] if
] when ;
: read-array ( -- array ) [ (read-array) ] { } make ;
: set-case ( -- object )
elements get element-newobj
elements get element-objtype {
elements get newobj>>
elements get objtype>> {
{ "boolean" [ "\0" = not ] }
{ "string" [ "" or ] }
{ "integer" [ be> ] }
@ -112,7 +112,7 @@ SYMBOL: end
} case ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
read1 dup elements get (>>id) ;
: read-ber ( syntax -- object )
element new
@ -124,7 +124,7 @@ SYMBOL: end
set-encoding
set-content-length
set-newobj
elements get element-syntax set-objtype
elements get syntax>> set-objtype
set-case
] [ end ] if ;
@ -181,7 +181,7 @@ TUPLE: tag value ;
] with-scope ; inline
: set-tag ( value -- )
tagnum get set-tag-value ;
tagnum get (>>value) ;
M: string >ber ( str -- byte-array )
tagnum get tag-value 1array "C" pack-native swap dup

2
extra/benchmark/empty-loop-0/empty-loop-0.factor
View File

@ -5,6 +5,6 @@ IN: benchmark.empty-loop-0
dup 0 fixnum< [ drop ] [ 1 fixnum-fast empty-loop-0 ] if ;
: empty-loop-main ( -- )
5000000 empty-loop-0 ;
50000000 empty-loop-0 ;
MAIN: empty-loop-main

2
extra/benchmark/empty-loop-1/empty-loop-1.factor
View File

@ -5,6 +5,6 @@ IN: benchmark.empty-loop-1
[ drop ] each-integer ;
: empty-loop-main ( -- )
5000000 empty-loop-1 ;
50000000 empty-loop-1 ;
MAIN: empty-loop-main

2
extra/benchmark/empty-loop-2/empty-loop-2.factor
View File

@ -5,6 +5,6 @@ IN: benchmark.empty-loop-2
[ drop ] each ;
: empty-loop-main ( -- )
5000000 empty-loop-2 ;
50000000 empty-loop-2 ;
MAIN: empty-loop-main

6
extra/benchmark/fib4/fib4.factor
View File

@ -1,7 +1,7 @@
USING: accessors math kernel debugger ;
IN: benchmark.fib4
TUPLE: box i ;
TUPLE: box { i read-only } ;
C: <box> box
@ -15,8 +15,8 @@ C: <box> box
i>> 1- <box>
tuple-fib
swap i>> swap i>> + <box>
] if ;
] if ; inline recursive
: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
: fib-main ( -- ) T{ box f 34 } tuple-fib i>> 9227465 assert= ;
MAIN: fib-main

17
extra/coroutines/coroutines.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables namespaces continuations quotations
accessors ;
IN: coroutines
USING: kernel hashtables namespaces continuations quotations ;
SYMBOL: current-coro
@ -13,12 +14,12 @@ TUPLE: coroutine resumecc exitcc ;
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
over set-coroutine-resumecc ;
>>resumecc ;
: coresume ( v co -- result )
[
over set-coroutine-exitcc
coroutine-resumecc call
>>exitcc
resumecc>> call
#! At this point, the coroutine quotation must have terminated
#! normally (without calling coyield or coterminate). This shouldn't happen.
f over
@ -31,8 +32,8 @@ TUPLE: coroutine resumecc exitcc ;
current-coro get
[
[ continue-with ] curry
over set-coroutine-resumecc
coroutine-exitcc continue-with
>>resumecc
exitcc>> continue-with
] callcc1 2nip ;
: coyield* ( v -- ) coyield drop ; inline
@ -40,5 +41,5 @@ TUPLE: coroutine resumecc exitcc ;
: coterminate ( v -- )
current-coro get
[ ] over set-coroutine-resumecc
coroutine-exitcc continue-with ;
[ ] >>resumecc
exitcc>> continue-with ;

4
extra/db/sqlite/lib/lib.factor
View File

@ -5,7 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors present urls io.encodings.utf8
io.encodings.string ;
io.encodings.string accessors ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
@ -16,7 +16,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
db get db-handle sqlite3_errmsg sqlite-sql-error ;
db get handle>> sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{

2
extra/db/sqlite/sqlite.factor
View File

@ -90,7 +90,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
] keep bind-statement ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
db get handle>> sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-db insert-tuple* ( tuple statement -- )

2
extra/db/tuples/tuples.factor
View File

@ -141,7 +141,7 @@ M: retryable execute-statement* ( statement type -- )
: update-tuple ( tuple -- )
dup class
db get db-update-statements [ <update-tuple-statement> ] cache
db get update-statements>> [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuples ( tuple -- )

36
extra/faq/faq.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator xml.writer namespaces
math.parser io ;
math.parser io accessors ;
IN: faq
: find-after ( seq quot -- elem after )
@ -21,16 +21,16 @@ C: <q/a> q/a
>r tag-children r> <q/a> ;
: q/a>li ( q/a -- li )
[ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
q/a-answer append "li" build-tag* ;
[ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
answer>> append "li" build-tag* ;
: xml>q/a ( xml -- q/a )
[ "question" tag-named tag-children ] keep
"answer" tag-named tag-children <q/a> ;
: q/a>xml ( q/a -- xml )
[ q/a-question "question" build-tag* ] keep
q/a-answer "answer" build-tag*
[ question>> "question" build-tag* ] keep
answer>> "answer" build-tag*
"\n" swap 3array "qa" build-tag* ;
! Lists of questions
@ -43,23 +43,23 @@ C: <question-list> question-list
<question-list> ;
: question-list>xml ( question-list -- list )
[ question-list-seq [ q/a>xml "\n" swap 2array ]
[ seq>> [ q/a>xml "\n" swap 2array ]
map concat "list" build-tag* ] keep
question-list-title [ "title" pick set-at ] when* ;
title>> [ "title" pick set-at ] when* ;
: html>question-list ( h3 ol -- question-list )
>r [ children>string ] [ f ] if* r>
children-tags [ li>q/a ] map <question-list> ;
: question-list>h3 ( id question-list -- h3 )
question-list-title [
title>> [
"h3" build-tag
swap number>string "id" pick set-at
] [ drop f ] if* ;
: question-list>html ( question-list start id -- h3/f ol )
-rot >r [ question-list>h3 ] keep
question-list-seq [ q/a>li ] map "ol" build-tag* r>
seq>> [ q/a>li ] map "ol" build-tag* r>
number>string "start" pick set-at
"margin-left: 5em" "style" pick set-at ;
@ -72,32 +72,32 @@ C: <faq> faq
first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
faq-lists first 1 -1 question-list>html nip , ;
dup header>> ,
lists>> first 1 -1 question-list>html nip , ;
: br, ( -- )
"br" contained, nl, ;
: toc-link, ( question-list number -- )
number>string "#" prepend "href" swap 2array 1array
"a" swap [ question-list-title , ] tag*, br, ;
"a" swap [ title>> , ] tag*, br, ;
: toc, ( faq -- )
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
"strong" [ "The big questions" , ] tag, br,
faq-lists rest dup length [ toc-link, ] 2each
lists>> rest dup length [ toc-link, ] 2each
] tag*, ;
: faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip
unclip seq>> length 1+ dupd
[ seq>> length + ] accumulate nip
0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
dup header,
dup toc,
faq-lists faq-sections,
lists>> faq-sections,
] make-xml ;
: xml>faq ( xml -- faq )
@ -106,8 +106,8 @@ C: <faq> faq
: faq>xml ( faq -- xml )
"faq" [
"header" [ dup faq-header , ] tag,
faq-lists [ question-list>xml , nl, ] each
"header" [ dup header>> , ] tag,
lists>> [ question-list>xml , nl, ] each
] make-xml ;
: read-write-faq ( xml-stream -- )

2
extra/ftp/server/server.factor
View File

@ -144,7 +144,7 @@ M: ftp-list service-command ( stream obj -- )
150 "Opening BINARY mode data connection for "
rot
[ file-name ] [
" " swap file-info file-info-size number>string
" " swap file-info size>> number>string
"(" " bytes)." swapd 3append append
] bi 3append server-response ;

93
extra/math/blas/matrices/matrices-docs.factor
View File

@ -1,4 +1,4 @@
USING: alien byte-arrays help.markup help.syntax math.blas.vectors sequences ;
USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
@ -52,13 +52,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
{ $subsection Mcols }
{ $subsection Msub }
"Matrix-vector products:"
{ $subsection n*M.V+n*V-in-place }
{ $subsection n*M.V+n*V! }
{ $subsection n*M.V+n*V }
{ $subsection n*M.V }
{ $subsection M.V }
"Vector outer products:"
{ $subsection n*V(*)V+M-in-place }
{ $subsection n*V(*)Vconj+M-in-place }
{ $subsection n*V(*)V+M! }
{ $subsection n*V(*)Vconj+M! }
{ $subsection n*V(*)V+M }
{ $subsection n*V(*)Vconj+M }
{ $subsection n*V(*)V }
@ -66,12 +66,12 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
{ $subsection V(*) }
{ $subsection V(*)conj }
"Matrix products:"
{ $subsection n*M.M+n*M-in-place }
{ $subsection n*M.M+n*M! }
{ $subsection n*M.M+n*M }
{ $subsection n*M.M }
{ $subsection M. }
"Scalar-matrix products:"
{ $subsection n*M-in-place }
{ $subsection n*M! }
{ $subsection n*M }
{ $subsection M*n }
{ $subsection M/n } ;
@ -111,134 +111,135 @@ HELP: double-complex-blas-matrix
} related-words
HELP: Mwidth
{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } }
{ $values { "matrix" blas-matrix-base } { "width" integer } }
{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ;
HELP: Mheight
{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } }
{ $values { "matrix" blas-matrix-base } { "height" integer } }
{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ;
{ Mwidth Mheight } related-words
HELP: n*M.V+n*V-in-place
{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } }
HELP: n*M.V+n*V!
{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" blas-vector-base } }
{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." }
{ $side-effects "y" } ;
HELP: n*V(*)V+M-in-place
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
HELP: n*V(*)V+M!
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" blas-matrix-base } }
{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." }
{ $side-effects "A" } ;
HELP: n*V(*)Vconj+M-in-place
{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } }
HELP: n*V(*)Vconj+M!
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" blas-matrix-base } }
{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." }
{ $side-effects "A" } ;
HELP: n*M.M+n*M-in-place
{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
HELP: n*M.M+n*M!
{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" blas-matrix-base } }
{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." }
{ $side-effects "C" } ;
HELP: <empty-matrix>
{ $values { "rows" "the number of rows the new matrix will have" } { "cols" "the number of columns the new matrix will have" } { "exemplar" "A BLAS vector inherited from " { $link blas-vector-base } " or BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } }
{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
{ <zero-vector> <empty-vector> <empty-matrix> } related-words
HELP: n*M.V+n*V
{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" blas-vector-base } }
{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ;
HELP: n*V(*)V+M
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" blas-matrix-base } }
{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
HELP: n*V(*)Vconj+M
{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" blas-matrix-base } }
{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ;
HELP: n*M.M+n*M
{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" blas-matrix-base } }
{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
HELP: n*M.V
{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" blas-vector-base } }
{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
HELP: M.V
{ $values { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" blas-vector-base } }
{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
{ n*M.V+n*V-in-place n*M.V+n*V n*M.V M.V } related-words
{ n*M.V+n*V! n*M.V+n*V n*M.V M.V } related-words
HELP: n*V(*)V
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-base } }
{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
HELP: n*V(*)Vconj
{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-base } }
{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
HELP: V(*)
{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-base } }
{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
HELP: V(*)conj
{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-base } }
{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
{ n*V(*)V+M-in-place n*V(*)Vconj+M-in-place n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
{ n*V(*)V+M! n*V(*)Vconj+M! n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
HELP: n*M.M
{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" blas-matrix-base } }
{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
HELP: M.
{ $values { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } }
{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" blas-matrix-base } }
{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
{ n*M.M+n*M-in-place n*M.M+n*M n*M.M M. } related-words
{ n*M.M+n*M! n*M.M+n*M n*M.M M. } related-words
HELP: Msub
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "row" "The topmost row of the slice" } { "col" "The leftmost column of the slice" } { "height" "The height of the slice" } { "width" "The width of the slice" } }
{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } }
{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ;
HELP: Mrows
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $values { "A" blas-matrix-base } { "rows" sequence } }
{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
HELP: Mcols
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $values { "A" blas-matrix-base } { "cols" sequence } }
{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
HELP: n*M-in-place
{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
HELP: n*M!
{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
{ $side-effects "A" } ;
HELP: n*M
{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $values { "n" number } { "A" blas-matrix-base } { "n*A" blas-matrix-base } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
HELP: M*n
{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } }
{ $values { "A" blas-matrix-base } { "n" number } { "A*n" blas-matrix-base } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
HELP: M/n
{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } }
{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } }
{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
{ n*M-in-place n*M M*n M/n } related-words
{ n*M! n*M M*n M/n } related-words
HELP: Mtranspose
{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $values { "matrix" blas-matrix-base } { "matrix^T" blas-matrix-base } }
{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ;
HELP: element-type
{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } }
{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
HELP: <empty-vector>
{ $values { "length" "The length of the new vector" } { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } }
{ $description "Return a vector of zeros with the given length and the same element type as " { $snippet "v" } "." } ;
{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;

72
extra/math/blas/matrices/matrices.factor
View File

@ -153,41 +153,45 @@ PRIVATE>
[ (flatten-complex-sequence) >c-double-array ] (>matrix)
<double-complex-blas-matrix> ;
GENERIC: n*M.V+n*V-in-place ( alpha A x beta y -- y=alpha*A.x+b*y )
GENERIC: n*V(*)V+M-in-place ( alpha x y A -- A=alpha*x(*)y+A )
GENERIC: n*V(*)Vconj+M-in-place ( alpha x y A -- A=alpha*x(*)yconj+A )
GENERIC: n*M.M+n*M-in-place ( alpha A B beta C -- C=alpha*A.B+beta*C )
GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
METHOD: n*M.V+n*V-in-place { real float-blas-matrix float-blas-vector real float-blas-vector }
METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector }
[ ] (prepare-gemv) [ cblas_sgemv ] dip ;
METHOD: n*M.V+n*V-in-place { real double-blas-matrix double-blas-vector real double-blas-vector }
METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector }
[ ] (prepare-gemv) [ cblas_dgemv ] dip ;
METHOD: n*M.V+n*V-in-place { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
[ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ;
METHOD: n*M.V+n*V-in-place { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
[ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ;
METHOD: n*V(*)V+M-in-place { real float-blas-vector float-blas-vector float-blas-matrix }
METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix }
[ ] (prepare-ger) [ cblas_sger ] dip ;
METHOD: n*V(*)V+M-in-place { real double-blas-vector double-blas-vector double-blas-matrix }
METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix }
[ ] (prepare-ger) [ cblas_dger ] dip ;
METHOD: n*V(*)V+M-in-place { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
[ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ;
METHOD: n*V(*)V+M-in-place { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
[ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ;
METHOD: n*V(*)Vconj+M-in-place { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
[ ] (prepare-ger) [ cblas_sger ] dip ;
METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
[ ] (prepare-ger) [ cblas_dger ] dip ;
METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
[ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ;
METHOD: n*V(*)Vconj+M-in-place { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
[ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ;
METHOD: n*M.M+n*M-in-place { real float-blas-matrix float-blas-matrix real float-blas-matrix }
METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix }
[ ] (prepare-gemm) [ cblas_sgemm ] dip ;
METHOD: n*M.M+n*M-in-place { real double-blas-matrix double-blas-matrix real double-blas-matrix }
METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix }
[ ] (prepare-gemm) [ cblas_dgemm ] dip ;
METHOD: n*M.M+n*M-in-place { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
[ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ;
METHOD: n*M.M+n*M-in-place { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
[ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ;
! XXX should do a dense clone
@ -206,36 +210,36 @@ syntax:M: blas-matrix-base clone
[ f swap (blas-matrix-like) ] 3tri ;
: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
clone n*M.V+n*V-in-place ;
clone n*M.V+n*V! ;
: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
clone n*V(*)V+M-in-place ;
clone n*V(*)V+M! ;
: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
clone n*V(*)Vconj+M-in-place ;
clone n*V(*)Vconj+M! ;
: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
clone n*M.M+n*M-in-place ;
clone n*M.M+n*M! ;
: n*M.V ( alpha A x -- alpha*A.x )
1.0 2over [ Mheight ] dip <empty-vector>
n*M.V+n*V-in-place ; inline
n*M.V+n*V! ; inline
: M.V ( A x -- A.x )
1.0 -rot n*M.V ; inline
: n*V(*)V ( n x y -- n*x(*)y )
: n*V(*)V ( alpha x y -- alpha*x(*)y )
2dup [ length>> ] bi@ pick <empty-matrix>
n*V(*)V+M-in-place ;
: n*V(*)Vconj ( n x y -- n*x(*)yconj )
n*V(*)V+M! ;
: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj )
2dup [ length>> ] bi@ pick <empty-matrix>
n*V(*)Vconj+M-in-place ;
n*V(*)Vconj+M! ;
: V(*) ( x y -- x(*)y )
1.0 -rot n*V(*)V ; inline
: V(*)conj ( x y -- x(*)yconj )
1.0 -rot n*V(*)Vconj ; inline
: n*M.M ( n A B -- n*A.B )
: n*M.M ( alpha A B -- alpha*A.B )
2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
1.0 swap n*M.M+n*M-in-place ;
1.0 swap n*M.M+n*M! ;
: M. ( A B -- A.B )
1.0 -rot n*M.M ; inline
@ -247,7 +251,7 @@ syntax:M: blas-matrix-base clone
height
width ;
: Msub ( matrix row col height width -- submatrix )
: Msub ( matrix row col height width -- sub )
5 npick dup transpose>>
[ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
swap (blas-matrix-like) ;
@ -281,14 +285,14 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
: Mrows ( A -- rows )
dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
: Mcols ( A -- rows )
: Mcols ( A -- cols )
dup transpose>> [ (Mrows) ] [ (Mcols) ] if ;
: n*M-in-place ( n A -- A=n*A )
[ (Mcols) [ n*V-in-place drop ] with each ] keep ;
: n*M! ( n A -- A=n*A )
[ (Mcols) [ n*V! drop ] with each ] keep ;
: n*M ( n A -- n*A )
clone n*M-in-place ; inline
clone n*M! ; inline
: M*n ( A n -- A*n )
swap n*M ; inline

52
extra/math/blas/vectors/vectors-docs.factor
View File

@ -1,4 +1,4 @@
USING: alien byte-arrays help.markup help.syntax sequences ;
USING: alien byte-arrays help.markup help.syntax math sequences ;
IN: math.blas.vectors
ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
@ -11,13 +11,13 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
{ $subsection Viamax }
{ $subsection Vamax }
"Scalar-vector products:"
{ $subsection n*V-in-place }
{ $subsection n*V! }
{ $subsection n*V }
{ $subsection V*n }
{ $subsection V/n }
{ $subsection Vneg }
"Vector addition:"
{ $subsection n*V+V-in-place }
{ $subsection n*V+V! }
{ $subsection n*V+V }
{ $subsection V+ }
{ $subsection V- }
@ -51,81 +51,81 @@ HELP: float-complex-blas-vector
HELP: double-complex-blas-vector
{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
HELP: n*V+V-in-place
{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
HELP: n*V+V!
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." }
{ $side-effects "y" } ;
HELP: n*V-in-place
{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
HELP: n*V!
{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" blas-vector-base } }
{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." }
{ $side-effects "x" } ;
HELP: V.
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } }
{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ;
HELP: V.conj
{ $values { "x" "a complex BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a complex BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } }
{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ;
HELP: Vnorm
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "norm" number } }
{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ;
HELP: Vasum
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "sum" number } }
{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ;
HELP: Vswap
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } }
{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
{ $side-effects "x" "y" } ;
HELP: Viamax
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "max-i" integer } }
{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ;
HELP: Vamax
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "max" number } }
{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ;
{ Viamax Vamax } related-words
HELP: <zero-vector>
{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "exemplar" blas-vector-base } { "zero" blas-vector-base } }
{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link <empty-vector> } "." } ;
HELP: n*V+V
{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" blas-vector-base } }
{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
HELP: n*V
{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" blas-vector-base } }
{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
HELP: V+
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" blas-vector-base } }
{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
HELP: V-
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" blas-vector-base } }
{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
HELP: Vneg
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result." } ;
{ $values { "x" blas-vector-base } { "-x" blas-vector-base } }
{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ;
HELP: V*n
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } }
{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" blas-vector-base } }
{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
HELP: V/n
{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } }
{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } }
{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
{ n*V+V-in-place n*V-in-place n*V+V n*V V+ V- Vneg V*n V/n } related-words
{ n*V+V! n*V! n*V+V n*V V+ V- Vneg V*n V/n } related-words
HELP: Vsub
{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } } { "start" "The index of the first element of the slice" } { "length" "The length of the slice" } }
{ $description "Slice a subvector out of " { $snippet "v" } " with the given length. The subvector will share storage with the parent vector." } ;
{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;

30
extra/math/blas/vectors/vectors.factor
View File

@ -21,8 +21,8 @@ C: <double-blas-vector> double-blas-vector
C: <float-complex-blas-vector> float-complex-blas-vector
C: <double-complex-blas-vector> double-complex-blas-vector
GENERIC: n*V+V-in-place ( alpha x y -- y=alpha*x+y )
GENERIC: n*V-in-place ( alpha x -- x=alpha*x )
GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
GENERIC: n*V! ( alpha x -- x=alpha*x )
GENERIC: V. ( x y -- x.y )
GENERIC: V.conj ( x y -- xconj.y )
@ -202,30 +202,30 @@ METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
(prepare-swap) [ cblas_zswap ] 2dip ;
METHOD: n*V+V-in-place { real float-blas-vector float-blas-vector }
METHOD: n*V+V! { real float-blas-vector float-blas-vector }
(prepare-axpy) [ cblas_saxpy ] dip ;
METHOD: n*V+V-in-place { real double-blas-vector double-blas-vector }
METHOD: n*V+V! { real double-blas-vector double-blas-vector }
(prepare-axpy) [ cblas_daxpy ] dip ;
METHOD: n*V+V-in-place { number float-complex-blas-vector float-complex-blas-vector }
METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector }
[ (>c-complex) ] 2dip
(prepare-axpy) [ cblas_caxpy ] dip ;
METHOD: n*V+V-in-place { number double-complex-blas-vector double-complex-blas-vector }
METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector }
[ (>z-complex) ] 2dip
(prepare-axpy) [ cblas_zaxpy ] dip ;
METHOD: n*V-in-place { real float-blas-vector }
METHOD: n*V! { real float-blas-vector }
(prepare-scal) [ cblas_sscal ] dip ;
METHOD: n*V-in-place { real double-blas-vector }
METHOD: n*V! { real double-blas-vector }
(prepare-scal) [ cblas_dscal ] dip ;
METHOD: n*V-in-place { number float-complex-blas-vector }
METHOD: n*V! { number float-complex-blas-vector }
[ (>c-complex) ] dip
(prepare-scal) [ cblas_cscal ] dip ;
METHOD: n*V-in-place { number double-complex-blas-vector }
METHOD: n*V! { number double-complex-blas-vector }
[ (>z-complex) ] dip
(prepare-scal) [ cblas_zscal ] dip ;
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V-in-place ; inline
: n*V ( alpha x -- alpha*x ) clone n*V-in-place ; inline
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
: V+ ( x y -- x+y )
1.0 -rot n*V+V ; inline
@ -251,6 +251,10 @@ METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
(prepare-dot)
"CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
METHOD: V.conj { float-blas-vector float-blas-vector }
(prepare-dot) cblas_sdot ;
METHOD: V.conj { double-blas-vector double-blas-vector }
(prepare-dot) cblas_ddot ;
METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
(prepare-dot)
"CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
@ -288,7 +292,7 @@ METHOD: Viamax { double-complex-blas-vector }
: Vamax ( x -- max )
[ Viamax ] keep nth ; inline
: Vsub ( v start length -- vsub )
: Vsub ( v start length -- sub )
rot [
[
nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri

14
extra/math/erato/erato.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
math.ranges sequences ;
math.ranges sequences accessors ;
IN: math.erato
<PRIVATE
@ -12,21 +12,21 @@ TUPLE: erato limit bits latest ;
2/ 1- ; inline
: is-prime ( n erato -- bool )
>r ind r> erato-bits nth ; inline
>r ind r> bits>> nth ; inline
: indices ( n erato -- range )
erato-limit ind over 3 * ind swap rot <range> ;
limit>> ind over 3 * ind swap rot <range> ;
: mark-multiples ( n erato -- )
over sq over erato-limit <=
[ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
over sq over limit>> <=
[ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
: <erato> ( n -- erato )
dup ind 1+ <bit-array> 1 over set-bits erato boa ;
: next-prime ( erato -- prime/f )
[ erato-latest 2 + ] keep [ set-erato-latest ] 2keep
2dup erato-limit <=
[ 2 + ] change-latest [ latest>> ] keep
2dup limit>> <=
[
2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
] [

10
extra/odbc/odbc.factor
View File

@ -213,7 +213,7 @@ C: <column> column
] if ;
: dereference-type-pointer ( byte-array column -- object )
column-type {
type>> {
{ SQL-CHAR [ ascii alien>string ] }
{ SQL-VARCHAR [ ascii alien>string ] }
{ SQL-LONGVARCHAR [ ascii alien>string ] }
@ -235,7 +235,7 @@ TUPLE: field value column ;
C: <field> field
: odbc-get-field ( statement column -- field )
dup column? [ dupd odbc-describe-column ] unless dup >r column-number
dup column? [ dupd odbc-describe-column ] unless dup >r number>>
SQL-C-DEFAULT
8192 CHAR: \space <string> ascii string>alien dup >r
8192
@ -244,15 +244,15 @@ C: <field> field
] [
r> drop r> [
"SQLGetData Failed for Column: " %
dup column-name %
" of type: " % dup column-type name>> %
dup name>> %
" of type: " % dup type>> name>> %
] "" make swap <field>
] if ;
: odbc-get-row-fields ( statement -- seq )
[
dup odbc-number-of-columns [
1+ odbc-get-field field-value ,
1+ odbc-get-field value>> ,
] with each
] { } make ;

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