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

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

db4
Bruno Deferrari 2008-08-31 15:52:48 -03:00
parent 9488d3da59 1cc5f7eb41
commit 504530276f
218 changed files with 1947 additions and 1294 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,8 +6,10 @@ HELP: ALIAS:
{ $values { "new-word" word } { "existing-word" word } }
{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
{ $examples
{ $example "ALIAS: sequence-nth nth"
"0 { 10 20 30 } sequence-nth"
{ $example "USING: alias prettyprint sequences ;"
"IN: alias.test"
"ALIAS: sequence-nth nth"
"0 { 10 20 30 } sequence-nth ."
"10"
}
} ;

1
basis/alias/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

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

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

@ -1,13 +1,13 @@
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 ;
kernel words slots assocs namespaces accessors ;
! Deprecated code
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-class 2array 2array
over name>>
rot class>> 2array 2array
[ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
@ -16,14 +16,14 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name suffix ,
{ $snippet } rot name>> suffix ,
" slot of " ,
{ $instance } swap suffix ,
" instance." ,
] { } make $description ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
[ reader>> eq? ] with find nip ;
: $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r>
@ -46,14 +46,14 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
{ $snippet } rot slot-spec-name suffix ,
{ $snippet } rot name>> suffix ,
" slot of " ,
{ $instance } swap suffix ,
" instance." ,
] { } make $description ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;
[ writer>> eq? ] with find nip ;
: $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r>
@ -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" }

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

@ -6,32 +6,32 @@ 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 [
[ class>> align-offset ] keep
[ set-slot-spec-offset ] 2keep
[ (>>offset) ] 2keep
class>> heap-size +
] reduce ;
: define-struct-slot-word ( spec word quot -- )
rot slot-spec-offset prefix define-inline ;
rot offset>> prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
[ ]
[ slot-spec-reader ]
[ 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 ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
[ ]
[ slot-spec-writer ]
[ writer>> ]
[ class>> c-setter ] 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

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

@ -28,4 +28,103 @@ 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

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

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

@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ;
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
f f f read-hms instant <timestamp> ;
0 0 0 read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
read-ymd f f f instant <timestamp> ;
read-ymd 0 0 0 instant <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;

10
basis/channels/channels.factor
View File

@ -3,7 +3,7 @@
!
! Channels - based on ideas from newsqueak
USING: kernel sequences sequences.lib threads continuations
random math ;
random math accessors ;
IN: channels
TUPLE: channel receivers senders ;
@ -17,14 +17,14 @@ GENERIC: from ( channel -- value )
<PRIVATE
: wait ( channel -- )
[ channel-senders push ] curry
[ senders>> push ] curry
"channel send" suspend drop ;
: (to) ( value receivers -- )
delete-random resume-with yield ;
: notify ( continuation channel -- channel )
[ channel-receivers push ] keep ;
[ receivers>> push ] keep ;
: (from) ( senders -- )
delete-random resume ;
@ -32,11 +32,11 @@ GENERIC: from ( channel -- value )
PRIVATE>
M: channel to ( value channel -- )
dup channel-receivers
dup receivers>>
dup empty? [ drop dup wait to ] [ nip (to) ] if ;
M: channel from ( channel -- value )
[
notify channel-senders
notify senders>>
dup empty? [ drop ] [ (from) ] if
] curry "channel receive" suspend ;

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:

7
basis/compiler/compiler.factor
View File

@ -42,12 +42,17 @@ SYMBOL: +failed+
[ compiled-unxref ]
[
dup crossref?
[ dependencies get compiled-xref ] [ drop ] if
[
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: (compile) ( word -- )
'[
H{ } clone dependencies set
H{ } clone generic-dependencies set
, {
[ compile-begins ]

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

5
basis/compiler/tests/insane.factor
View File

@ -1,4 +1,5 @@
IN: compiler.tests
USING: words kernel stack-checker alien.strings tools.test ;
USING: words kernel stack-checker alien.strings tools.test
compiler.units ;
[ ] [ \ if redefined [ string>alien ] infer. ] unit-test
[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test

29
basis/compiler/tests/redefine10.factor Normal file
View File

@ -0,0 +1,29 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math classes ;
IN: compiler.tests.redefine10
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
"> eval
] unit-test
[ 2.0 ] [
1.0 "my-inline" "compiler.tests.redefine10" lookup execute
] unit-test

32
basis/compiler/tests/redefine11.factor Normal file
View File

@ -0,0 +1,32 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math classes arrays ;
IN: compiler.tests.redefine11
MIXIN: my-mixin
INSTANCE: array my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
"> eval
] unit-test
[ ] [
[
array "my-mixin" "compiler.tests.redefine11" lookup
remove-mixin-instance
] with-compilation-unit
] unit-test
[ 1 ] [
"my-inline" "compiler.tests.redefine11" lookup execute
] unit-test

33
basis/compiler/tests/redefine6.factor Normal file
View File

@ -0,0 +1,33 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel kernel.private ;
IN: compiler.tests.redefine6
GENERIC: my-generic ( a -- b )
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> eval
] unit-test
[ ] [
<"
USING: kernel ;
IN: compiler.tests.redefine6
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
"> eval
] unit-test
[ 1 ] [
"my-tuple" "compiler.tests.redefine6" lookup boa
"my-inline" "compiler.tests.redefine6" lookup execute
] unit-test

29
basis/compiler/tests/redefine7.factor Normal file
View File

@ -0,0 +1,29 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math ;
IN: compiler.tests.redefine7
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
"> eval
] unit-test
[ 2.0 ] [
1.0 "my-inline" "compiler.tests.redefine7" lookup execute
] unit-test

32
basis/compiler/tests/redefine8.factor Normal file
View File

@ -0,0 +1,32 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math math.order sorting ;
IN: compiler.tests.redefine8
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
"> eval
] unit-test
[ 2.0 ] [
1.0 "my-generic" "compiler.tests.redefine8" lookup execute
] unit-test

35
basis/compiler/tests/redefine9.factor Normal file
View File

@ -0,0 +1,35 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math math.order sorting ;
IN: compiler.tests.redefine9
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
"> eval
] unit-test
[
"my-tuple" "compiler.tests.redefine9" lookup boa
"my-generic" "compiler.tests.redefine9" lookup
execute
] [ no-math-method? ] must-fail-with

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

@ -42,7 +42,7 @@ GENERIC: cleanup* ( node -- node/nodes )
: cleanup-folding ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
[ word>> +inlined+ depends-on ]
[ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
@ -50,11 +50,16 @@ GENERIC: cleanup* ( node -- node/nodes )
[ in-d>> #drop ]
tri prefix ;
: add-method-dependency ( #call -- )
dup method>> word? [
[ word>> ] [ class>> ] bi depends-on-generic
] [ drop ] if ;
: cleanup-inlining ( #call -- nodes )
[
dup method>>
[ method>> dup word? [ +called+ depends-on ] [ drop ] if ]
[ word>> +inlined+ depends-on ] if
[ add-method-dependency ]
[ word>> inlined-dependency depends-on ] if
] [ body>> cleanup ] bi ;
! Removing overflow checks

2
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -106,7 +106,7 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
[ word>> +inlined+ depends-on ]
[ word>> flushed-dependency depends-on ]
[ in-d>> #drop remove-dead-code* ]
bi ;

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

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

@ -24,18 +24,19 @@ M: quotation splicing-nodes
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call word/quot/f -- ? )
[
: eliminate-dispatch ( #call class/f word/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
propagate-body t
] [ f >>method f >>body drop f ] if* ;
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- method/f )
: inlining-standard-method ( #call word -- class/f method/f )
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> ] dip
[ swap nth value-info class>> dup ] dip
specific-method ;
: inline-standard-method ( #call word -- ? )
@ -51,15 +52,17 @@ M: quotation splicing-nodes
object
} [ class<= ] with find nip ;
: inlining-math-method ( #call word -- quot/f )
: inlining-math-method ( #call word -- class/f quot/f )
swap in-d>>
first2 [ value-info class>> normalize-math-class ] bi@
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
3dup math-both-known?
[ math-method* ] [ 3drop f ] if
number swap ;
: inline-math-method ( #call word -- ? )
dupd inlining-math-method eliminate-dispatch ;
: inlining-math-partial ( #call word -- quot/f )
: inlining-math-partial ( #call word -- class/f quot/f )
[ "derived-from" word-prop first inlining-math-method ]
[ nip 1quotation ] 2bi
[ = not ] [ drop ] 2bi and ;

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

@ -5,6 +5,8 @@ math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private slots.private
definitions
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -280,6 +282,14 @@ generic-comparison-ops [
] +constraints+ set-word-prop
\ instance? [
! We need to force the caller word to recompile when the class
! is redefined, since now we're making assumptions but the
! class definition itself.
dup literal>> class?
[ literal>> predicate-output-infos ] [ 2drop object-info ] if
[
literal>>
[ inlined-dependency depends-on ]
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if
] +outputs+ set-word-prop

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

@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays byte-arrays strings
math math.partial-dispatch math.private slots generic
classes.tuple.private continuations arrays
math math.partial-dispatch math.private slots generic definitions
generic.standard generic.math
stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -32,7 +33,14 @@ M: #push propagate-before
[ set-value-info ] 2each ;
M: #declare propagate-before
declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
#! We need to force the caller word to recompile when the
#! classes mentioned in the declaration are redefined, since
#! now we're making assumptions but their definitions.
declaration>> [
[ inlined-dependency depends-on ]
[ <class-info> swap refine-value-info ]
bi
] assoc-each ;
: predicate-constraints ( value class boolean-value -- constraint )
[ [ is-instance-of ] dip t--> ]
@ -74,7 +82,11 @@ M: #declare propagate-before
} cond 2nip ;
: propagate-predicate ( #call word -- infos )
[ in-d>> first value-info ] [ "predicating" word-prop ] bi*
#! We need to force the caller word to recompile when the class
#! is redefined, since now we're making assumptions but the
#! class definition itself.
[ in-d>> first value-info ]
[ "predicating" word-prop dup inlined-dependency depends-on ] bi*
predicate-output-infos 1array ;
: default-output-value-infos ( #call word -- infos )

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

@ -17,7 +17,7 @@ TUPLE: #introduce < node out-d ;
: #introduce ( out-d -- node )
\ #introduce new swap >>out-d ;
TUPLE: #call < node word in-d out-d body method info ;
TUPLE: #call < node word in-d out-d body method class info ;
: #call ( inputs outputs word -- node )
\ #call new

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

4
basis/concurrency/locks/locks-tests.factor
View File

@ -1,7 +1,7 @@
IN: concurrency.locks.tests
USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar ;
threads sequences calendar accessors ;
:: lock-test-0 ( -- )
[let | v [ V{ } clone ]
@ -174,7 +174,7 @@ threads sequences calendar ;
] ;
[ lock-timeout-test ] [
linked-error-thread thread-name "Lock timeout-er" =
thread>> name>> "Lock timeout-er" =
] must-fail-with
:: read/write-test ( -- )

45
basis/concurrency/locks/locks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math
concurrency.conditions ;
concurrency.conditions combinators.short-circuit accessors ;
IN: concurrency.locks
! Simple critical sections
@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ;
<PRIVATE
: acquire-lock ( lock timeout -- )
over lock-owner
[ 2dup >r lock-threads r> "lock" wait ] when drop
self swap set-lock-owner ;
over owner>>
[ 2dup >r threads>> r> "lock" wait ] when drop
self >>owner drop ;
: release-lock ( lock -- )
f over set-lock-owner
lock-threads notify-1 ;
f >>owner
threads>> notify-1 ;
: do-lock ( lock timeout quot acquire release -- )
>r >r pick rot r> call ! use up timeout acquire
@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ;
PRIVATE>
: with-lock-timeout ( lock timeout quot -- )
pick lock-reentrant? [
pick lock-owner self eq? [
pick reentrant?>> [
pick owner>> self eq? [
2nip call
] [
(with-lock)
@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ;
<PRIVATE
: add-reader ( lock -- )
dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
[ 1+ ] change-reader# drop ;
: acquire-read-lock ( lock timeout -- )
over rw-lock-writer
[ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
over writer>>
[ 2dup >r readers>> r> "read lock" wait ] when drop
add-reader ;
: notify-writer ( lock -- )
rw-lock-writers notify-1 ;
writers>> notify-1 ;
: remove-reader ( lock -- )
dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
[ 1- ] change-reader# drop ;
: release-read-lock ( lock -- )
dup remove-reader
dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
dup reader#>> zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- )
over rw-lock-writer pick rw-lock-reader# 0 > or
[ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
self swap set-rw-lock-writer ;
over writer>> pick reader#>> 0 > or
[ 2dup >r writers>> r> "write lock" wait ] when drop
self >>writer drop ;
: release-write-lock ( lock -- )
f over set-rw-lock-writer
dup rw-lock-readers deque-empty?
[ notify-writer ] [ rw-lock-readers notify-all ] if ;
f >>writer
dup readers>> deque-empty?
[ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read
#! lock too.
rw-lock-writer self eq? ;
writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy.
dup rw-lock-writer self eq?
swap rw-lock-reader# zero? and ;
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
PRIVATE>

2
basis/concurrency/messaging/messaging-tests.factor
View File

@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data clear-deque ] unit-test
[ ] [ my-mailbox data>> clear-deque ] unit-test
[ "received" ] [
[

4
basis/concurrency/messaging/messaging.factor
View File

@ -10,8 +10,8 @@ IN: concurrency.messaging
GENERIC: send ( message thread -- )
: mailbox-of ( thread -- mailbox )
dup thread-mailbox [ ] [
<mailbox> dup rot set-thread-mailbox
dup mailbox>> [ ] [
<mailbox> [ >>mailbox drop ] keep
] ?if ;
M: thread send ( message thread -- )

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

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

@ -58,8 +58,7 @@ INSTANCE: float-array sequence
: 4float-array ( w x y z -- array )
T{ float-array } 4sequence ; inline
: F{ ( parsed -- parsed )
\ } [ >float-array ] parse-literal ; parsing
: F{ \ } [ >float-array ] parse-literal ; parsing
M: float-array pprint-delims drop \ F{ \ } ;

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

9
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 +inlined+ changed-definition
set-vocab-help ; parsing
dup changed-definition
scan-object >>help drop ; parsing

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

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

2
basis/hints/hints.factor
View File

@ -55,7 +55,7 @@ IN: hints
: HINTS:
scan-word
[ +inlined+ changed-definition ]
[ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing

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

8
basis/io/servers/connection/connection.factor
View File

@ -41,7 +41,7 @@ ready ;
SYMBOL: remote-address
GENERIC: handle-client* ( server -- )
GENERIC: handle-client* ( threaded-server -- )
<PRIVATE
@ -75,13 +75,13 @@ M: threaded-server handle-client* handler>> call ;
: thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ;
: accept-connection ( server -- )
: accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi
[ '[ , , , handle-client ] ]
[ drop threaded-server get name>> swap thread-name ] 2bi
spawn drop ;
: accept-loop ( server -- )
: accept-loop ( threaded-server -- )
[
threaded-server get semaphore>>
[ [ accept-connection ] with-semaphore ]
@ -89,7 +89,7 @@ M: threaded-server handle-client* handler>> call ;
if*
] [ accept-loop ] bi ; inline recursive
: started-accept-loop ( server -- )
: started-accept-loop ( threaded-server -- )
threaded-server get
[ sockets>> push ] [ ready>> raise-flag ] bi ;

2
basis/io/sockets/sockets-docs.factor
View File

@ -62,7 +62,7 @@ ARTICLE: "network-streams" "Networking"
ABOUT: "network-streams"
HELP: local
{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $link local-path } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $snippet "path" } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
{ $examples
{ $code "\"/tmp/.X11-unix/0\" <local>" }
} ;

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

11
basis/multiline/multiline.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces parser lexer kernel sequences words quotations math ;
USING: namespaces parser lexer kernel sequences words quotations math
accessors ;
IN: multiline
: next-line-text ( -- str )
lexer get dup next-line lexer-line-text ;
lexer get dup next-line line-text>> ;
: (parse-here) ( -- )
next-line-text [
@ -22,7 +23,7 @@ IN: multiline
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get lexer-line-text [
lexer get line-text>> [
2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0
@ -32,8 +33,8 @@ IN: multiline
: parse-multiline-string ( end-text -- str )
[
lexer get lexer-column swap (parse-multiline-string)
lexer get set-lexer-column
lexer get column>> swap (parse-multiline-string)
lexer get (>>column)
] "" make rest but-last ;
: <"

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/persistent/heaps/heaps-docs.factor
View File

@ -38,7 +38,7 @@ HELP: pheap>alist
{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
HELP: pheap>values
{ $values { "heap" "a persistent heap" } { "values" array } }
{ $values { "heap" "a persistent heap" } { "seq" array } }
{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
ARTICLE: "persistent-heaps" "Persistent heaps"

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? ( -- ? )

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

@ -195,11 +195,11 @@ DEFER: parse-error-file
: string-layout
{
"USING: debugger io kernel lexer ;"
"USING: accessors debugger io kernel ;"
"IN: prettyprint.tests"
": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write"
" \" but got \" write unexpected-got expected>string print ;"
" \"Expected \" write dup want>> expected>string write"
" \" but got \" write got>> expected>string print ;"
} ;

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 ;

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

@ -115,10 +115,10 @@ M: object short-section? section-fits? ;
: pprint-section ( section -- )
dup short-section? [
dup section-style [ short-section ] with-style
dup style>> [ short-section ] with-style
] [
[ <long-section ]
[ dup section-style [ long-section ] with-style ]
[ dup style>> [ long-section ] with-style ]
[ long-section> ]
tri
] if ;
@ -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 )
[

26
basis/stack-checker/backend/backend.factor
View File

@ -8,29 +8,6 @@ sets generic.standard.engines.tuple stack-checker.state
stack-checker.visitor stack-checker.errors ;
IN: stack-checker.backend
! Word properties we use
SYMBOL: visited
: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ visited get conjoin ]
[
crossref get at keys
[ word? ] filter
[
[ reset-on-redefine [ word-prop ] with contains? ]
[ inline? ]
bi or
] filter
[ (redefined) ] each
] tri
] if ;
M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
: push-d ( obj -- ) meta-d get push ;
: pop-d ( -- obj )
@ -72,7 +49,7 @@ GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
[ dup word? [ +called+ depends-on ] [ drop ] if ]
[ dup word? [ called-dependency depends-on ] [ drop ] if ]
[ push-literal ]
bi ;
@ -175,6 +152,7 @@ M: object apply-object push-literal ;
init-known-values
stack-visitor off
dependencies off
generic-dependencies off
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
[ finish-word current-effect ]
bi

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

@ -140,7 +140,7 @@ SYMBOL: enter-out
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
[ +inlined+ depends-on ]
[ inlined-dependency depends-on ]
[
{
{ [ dup inline-recursive-label ] [ call-recursive-inline-word ] }

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

@ -176,7 +176,7 @@ do-primitive alien-invoke alien-indirect alien-callback
SYMBOL: +primitive+
: non-inline-word ( word -- )
dup +called+ depends-on
dup called-dependency depends-on
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }

18
basis/stack-checker/state/state-tests.factor
View File

@ -9,22 +9,22 @@ definitions ;
SYMBOL: a
SYMBOL: b
[ ] [ a +called+ depends-on ] unit-test
[ ] [ a called-dependency depends-on ] unit-test
[ H{ { a +called+ } } ] [
[ a +called+ depends-on ] computing-dependencies
[ H{ { a called-dependency } } ] [
[ a called-dependency depends-on ] computing-dependencies
] unit-test
[ H{ { a +called+ } { b +inlined+ } } ] [
[ H{ { a called-dependency } { b inlined-dependency } } ] [
[
a +called+ depends-on b +inlined+ depends-on
a called-dependency depends-on b inlined-dependency depends-on
] computing-dependencies
] unit-test
[ H{ { a +inlined+ } { b +inlined+ } } ] [
[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
[
a +inlined+ depends-on
a +called+ depends-on
b +inlined+ depends-on
a inlined-dependency depends-on
a called-dependency depends-on
b inlined-dependency depends-on
] computing-dependencies
] unit-test

15
basis/stack-checker/state/state.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel definitions math
effects accessors words stack-checker.errors ;
effects accessors words fry classes.algebra stack-checker.errors
compiler.units ;
IN: stack-checker.state
: <value> ( -- value ) \ <value> counter ;
@ -88,9 +89,15 @@ SYMBOL: meta-r
SYMBOL: dependencies
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
dependencies get dup
[ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ;
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
: depends-on-generic ( generic class -- )
generic-dependencies get dup
[ swap '[ null or , class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded

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

@ -46,7 +46,7 @@ SYMBOL: +transform-n+
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- )
[ +inlined+ depends-on ] [
[ inlined-dependency depends-on ] [
[ ]
[ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ]
@ -55,7 +55,7 @@ SYMBOL: +transform-n+
] bi ;
: apply-macro ( word -- )
[ +inlined+ depends-on ] [
[ inlined-dependency depends-on ] [
[ ]
[ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ]
@ -92,13 +92,13 @@ SYMBOL: +transform-n+
\ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
[ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
! Constructors
\ boa [
dup tuple-class? [
dup +inlined+ depends-on
dup inlined-dependency depends-on
[ "boa-check" word-prop ]
[ tuple-layout '[ , <tuple-boa> ] ]
bi append
@ -107,7 +107,7 @@ SYMBOL: +transform-n+
\ new [
dup tuple-class? [
dup +inlined+ depends-on
dup inlined-dependency depends-on
dup all-slots rest-slice ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
] [ drop f ] if

10
basis/threads/threads-docs.factor
View File

@ -38,7 +38,7 @@ ARTICLE: "thread-state" "Thread-local state and variables"
{ $subsection tchange }
"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
$nl
"Global hashtable of all threads, keyed by " { $link thread-id } ":"
"Global hashtable of all threads, keyed by " { $snippet "id" } ":"
{ $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
@ -63,10 +63,10 @@ ABOUT: "threads"
HELP: thread
{ $class-description "A thread. The slots are as follows:"
{ $list
{ { $link thread-id } " - a unique identifier assigned to each thread." }
{ { $link thread-name } " - the name passed to " { $link spawn } "." }
{ { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
{ { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
{ { $snippet "id" } " - a unique identifier assigned to each thread." }
{ { $snippet "name" } " - the name passed to " { $link spawn } "." }
{ { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." }
{ { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
}
} ;

14
basis/tools/deploy/deploy-tests.factor
View File

@ -35,13 +35,13 @@ namespaces continuations layouts accessors ;
[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "tetris" shake-and-bake ] unit-test
[ t ] [ 1500000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
! [ ] [ "tetris" shake-and-bake ] unit-test
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
! [ ] [ "bunny" shake-and-bake ] unit-test
!
! [ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"

18
basis/tools/deploy/test/2/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.2" }
{ deploy-threads? t }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-reflection 2 }
{ deploy-ui? f }
{ "stop-after-last-window?" t }
{ 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-word-defs? f }
}

8
basis/tools/threads/threads.factor
View File

@ -6,14 +6,14 @@ heaps.private system math math.parser math.order accessors ;
IN: tools.threads
: thread. ( thread -- )
dup thread-id pprint-cell
dup thread-name over [ write-object ] with-cell
dup thread-state [
dup id>> pprint-cell
dup name>> over [ write-object ] with-cell
dup state>> [
[ dup self eq? "running" "yield" ? ] unless*
write
] with-cell
[
thread-sleep-entry [
sleep-entry>> [
key>> millis [-] number>string write
" ms" write
] when*

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

8
basis/tools/vocabs/vocabs.factor
View File

@ -4,7 +4,7 @@ USING: kernel io io.styles io.files io.encodings.utf8
vocabs.loader vocabs sequences namespaces math.parser arrays
hashtables assocs memoize summary sorting splitting combinators
source-files debugger continuations compiler.errors init
checksums checksums.crc32 sets ;
checksums checksums.crc32 sets accessors ;
IN: tools.vocabs
: vocab-tests-file ( vocab -- path )
@ -61,10 +61,10 @@ SYMBOL: failures
: source-modified? ( path -- ? )
dup source-files get at [
dup source-file-path
dup path>>
dup exists? [
utf8 file-lines crc32 checksum-lines
swap source-file-checksum = not
swap checksum>> = not
] [
2drop f
] if
@ -175,7 +175,7 @@ M: vocab summary
[
dup vocab-summary %
" (" %
vocab-words assoc-size #
words>> assoc-size #
" words)" %
] "" make ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals continuations
threads namespaces namespaces.private assocs ;
threads namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
@ -26,6 +26,6 @@ IN: tools.walker.debug
send-synchronous drop
p ?promise
thread-variables walker-continuation swap at
model-value continuation-data
variables>> walker-continuation swap at
value>> data>>
] ;

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

@ -22,8 +22,8 @@ DEFER: start-walker-thread
: get-walker-thread ( -- status continuation thread )
walker-thread tget [
[ thread-variables walker-status swap at ]
[ thread-variables walker-continuation swap at ]
[ variables>> walker-status swap at ]
[ variables>> walker-continuation swap at ]
[ ] tri
] [
f <model>
@ -43,7 +43,7 @@ DEFER: start-walker-thread
} cond ;
: break ( -- )
continuation callstack over set-continuation-call
continuation callstack >>call
show-walker send-synchronous
after-break ;
@ -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 ;
@ -248,7 +248,7 @@ SYMBOL: +stopped+
: associate-thread ( walker -- )
walker-thread tset
[ f walker-thread tget send-synchronous drop ]
self set-thread-exit-handler ;
self (>>exit-handler) ;
: start-walker-thread ( status continuation -- thread' )
self [
@ -258,7 +258,7 @@ SYMBOL: +stopped+
V{ } clone walker-history tset
walker-loop
] 3curry
"Walker on " self thread-name append spawn
"Walker on " self name>> append spawn
[ associate-thread ] keep ;
! For convenience

23
basis/ui/clipboards/clipboards.factor
View File

@ -1,10 +1,22 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ui.gadgets ui.gestures namespaces ;
USING: kernel accessors ui.gadgets ui.gestures namespaces ;
IN: ui.clipboards
! Two text transfer buffers
TUPLE: clipboard contents ;
GENERIC: clipboard-contents ( clipboard -- string )
GENERIC: set-clipboard-contents ( string clipboard -- )
M: clipboard clipboard-contents contents>> ;
M: clipboard set-clipboard-contents (>>contents) ;
: <clipboard> ( -- clipboard ) "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
@ -20,11 +32,10 @@ SYMBOL: clipboard
SYMBOL: selection
: gadget-copy ( gadget clipboard -- )
over gadget-selection? [
>r [ gadget-selection ] keep r> copy-clipboard
] [
2drop
] if ;
over gadget-selection?
[ >r [ gadget-selection ] keep r> copy-clipboard ]
[ 2drop ]
if ;
: com-copy ( gadget -- ) clipboard get gadget-copy ;

35
basis/ui/freetype/freetype-docs.factor
View File

@ -16,12 +16,35 @@ HELP: init-freetype
{ $notes "Do not call this word if you are using the UI." } ;
HELP: font
{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
{ $list
{ { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
{ { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
{ { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
}
{ $class-description
"A font which has been loaded by FreeType. Font instances have the following slots:"
{
$list
{
{ $snippet "ascent" } ", "
{ $snippet "descent" } ", "
{ $snippet "height" } " - metrics."
}
{
{ $snippet "handle" }
" - alien pointer to an "
{ $snippet "FT_Face" } "."
}
{
{ $snippet "widths" }
" - sequence of character widths. Use "
{ $snippet "width" }
" and "
{ $snippet "width" }
" to compute string widths instead of reading this sequence directly."
}
}
} ;
HELP: close-freetype

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

@ -33,7 +33,7 @@ ascent descent height handle widths ;
M: font hashcode* drop font hashcode* ;
: close-font ( font -- ) font-handle FT_Done_Face ;
: close-font ( font -- ) handle>> FT_Done_Face ;
: close-freetype ( -- )
global [
@ -111,11 +111,11 @@ M: freetype-renderer open-font ( font -- open-font )
freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
>r font-handle dup r> 0 FT_Load_Char
>r handle>> dup r> 0 FT_Load_Char
freetype-error face-glyph ;
: char-width ( open-font char -- w )
over font-widths [
over widths>> [
dupd load-glyph glyph-hori-advance ft-ceil
] cache nip ;
@ -123,7 +123,7 @@ M: freetype-renderer string-width ( open-font string -- w )
0 -rot [ char-width + ] with each ;
M: freetype-renderer string-height ( open-font string -- h )
drop font-height ;
drop height>> ;
: glyph-size ( glyph -- dim )
dup glyph-hori-advance ft-ceil
@ -166,7 +166,7 @@ M: freetype-renderer string-height ( open-font string -- h )
: glyph-texture-loc ( glyph font -- loc )
over glyph-hori-bearing-x ft-floor -rot
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
ascent>> swap glyph-hori-bearing-y - ft-floor 2array ;
: glyph-texture-size ( glyph -- dim )
[ glyph-bitmap-width next-power-of-2 ]
@ -203,7 +203,7 @@ M: freetype-renderer string-height ( open-font string -- h )
] do-enabled ;
: font-sprites ( font world -- open-font sprites )
world-fonts [ open-font H{ } clone 2array ] cache first2 ;
fonts>> [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
>r >r world get font-sprites r> r> (draw-string) ;

2
basis/ui/gadgets/books/books-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.gadgets models ;
IN: ui.gadgets.books
HELP: book
{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $snippet "visible?" } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
$nl
"Books are created by calling " { $link <book> } "." } ;

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

@ -5,7 +5,7 @@ IN: ui.gadgets.books
TUPLE: book < gadget ;
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
: hide-all ( book -- ) children>> [ hide-gadget ] each ;
: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;

12
basis/ui/gadgets/buttons/buttons-docs.factor
View File

@ -5,9 +5,9 @@ IN: ui.gadgets.buttons
HELP: button
{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
$nl
"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-paint } "."
$nl
"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
HELP: <button>
{ $values { "label" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
@ -28,10 +28,10 @@ HELP: <repeat-button>
HELP: button-paint
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
{ $list
{ { $link button-paint-plain } " - the button is inactive" }
{ { $link button-paint-rollover } " - the button is under the mouse" }
{ { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
{ { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> } }
{ { $snippet "plain" } " - the button is inactive" }
{ { $snippet "rollover" } " - the button is under the mouse" }
{ { $snippet "pressed" } " - the button is under the mouse and a mouse button is held down" }
{ { $snippet "selected" } " - the button is selected (see " { $link <toggle-buttons> } }
}
"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;

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

@ -25,14 +25,13 @@ TUPLE: button < border pressed? selected? quot ;
dup mouse-clicked?
over button-rollover? and
buttons-down? and
over set-button-pressed?
over (>>pressed?)
relayout-1 ;
: if-clicked ( button quot -- )
>r dup button-update dup button-rollover? r> [ drop ] if ;
: button-clicked ( button -- )
dup button-quot if-clicked ;
: button-clicked ( button -- ) dup quot>> if-clicked ;
button H{
{ T{ button-up } [ button-clicked ] }
@ -106,7 +105,7 @@ TUPLE: checkmark-paint color ;
C: <checkmark-paint> checkmark-paint
M: checkmark-paint draw-interior
checkmark-paint-color set-color
color>> set-color
origin get [
rect-dim
{ 0 0 } over gl-line
@ -119,9 +118,9 @@ M: checkmark-paint draw-interior
black <solid>
black <checkmark-paint>
<button-paint>
over set-gadget-interior
over (>>interior)
black <solid>
swap set-gadget-boundary ;
swap (>>boundary) ;
: <checkmark> ( -- gadget )
<gadget>
@ -145,18 +144,18 @@ TUPLE: checkbox < button ;
swap >>model ;
M: checkbox model-changed
swap model-value over set-button-selected? relayout-1 ;
swap model-value over (>>selected?) relayout-1 ;
TUPLE: radio-paint color ;
C: <radio-paint> radio-paint
M: radio-paint draw-interior
radio-paint-color set-color
color>> set-color
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
M: radio-paint draw-boundary
radio-paint-color set-color
color>> set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
: radio-knob-theme ( gadget -- )
@ -165,9 +164,9 @@ M: radio-paint draw-boundary
black <radio-paint>
black <radio-paint>
<button-paint>
over set-gadget-interior
over (>>interior)
black <radio-paint>
swap set-gadget-boundary ;
swap (>>boundary) ;
: <radio-knob> ( -- gadget )
<gadget>
@ -184,8 +183,8 @@ TUPLE: radio-control < button value ;
M: radio-control model-changed
swap model-value
over radio-control-value =
over set-button-selected?
over value>> =
over (>>selected?)
relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent )

32
basis/ui/gadgets/editors/editors-docs.factor
View File

@ -7,32 +7,34 @@ HELP: editor
$nl
"Editors have the following slots:"
{ $list
{ { $link editor-font } " - a font specifier." }
{ { $link editor-color } " - text color specifier." }
{ { $link editor-caret-color } " - caret color specifier." }
{ { $link editor-selection-color } " - selection background color specifier." }
{ { $link editor-caret } " - a model storing a line/column pair." }
{ { $link editor-mark } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
{ { $link editor-focused? } " - a boolean." }
{ { $snippet "font" } " - a font specifier." }
{ { $snippet "color" } " - text color specifier." }
{ { $snippet "caret-color" } " - caret color specifier." }
{ { $snippet "selection-color" } " - selection background color specifier." }
{ { $snippet "caret" } " - a model storing a line/column pair." }
{ { $snippet "mark" } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
{ { $snippet "focused?" } " - a boolean." }
} } ;
HELP: <editor>
{ $values { "editor" "a new " { $link editor } } }
{ $description "Creates a new " { $link editor } " with an empty document." } ;
HELP: editor-caret ( editor -- caret )
{ $values { "editor" editor } { "caret" model } }
{ $description "Outputs a " { $link model } " holding the current caret location." } ;
! 'editor-caret' is now an old accessor, but it's documented as a word here. Maybe move this description somewhere else.
{ editor-caret editor-caret* editor-mark editor-mark* } related-words
! HELP: editor-caret ( editor -- caret )
! { $values { "editor" editor } { "caret" model } }
! { $description "Outputs a " { $link model } " holding the current caret location." } ;
{ editor-caret* editor-mark* } related-words
HELP: editor-caret*
{ $values { "editor" editor } { "loc" "a pair of integers" } }
{ $description "Outputs the current caret location as a line/column number pair." } ;
HELP: editor-mark ( editor -- mark )
{ $values { "editor" editor } { "mark" model } }
{ $description "Outputs a " { $link model } " holding the current mark location." } ;
! HELP: editor-mark ( editor -- mark )
! { $values { "editor" editor } { "mark" model } }
! { $description "Outputs a " { $link model } " holding the current mark location." } ;
HELP: editor-mark*
{ $values { "editor" editor } { "loc" "a pair of integers" } }
@ -74,9 +76,7 @@ HELP: set-editor-string
ARTICLE: "gadgets-editors-selection" "The caret and mark"
"If there is no selection, the caret and the mark are at the same location; otherwise the mark delimits the end-point of the selection opposite the caret."
{ $subsection editor-caret }
{ $subsection editor-caret* }
{ $subsection editor-mark }
{ $subsection editor-mark* }
{ $subsection change-caret }
{ $subsection change-caret&mark }

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

@ -38,50 +38,50 @@ focused? ;
: activate-editor-model ( editor model -- )
2dup add-connection
dup activate-model
swap gadget-model add-loc ;
swap model>> add-loc ;
: deactivate-editor-model ( editor model -- )
2dup remove-connection
dup deactivate-model
swap gadget-model remove-loc ;
swap model>> remove-loc ;
M: editor graft*
dup
dup editor-caret activate-editor-model
dup editor-mark activate-editor-model ;
dup caret>> activate-editor-model
dup mark>> activate-editor-model ;
M: editor ungraft*
dup
dup editor-caret deactivate-editor-model
dup editor-mark deactivate-editor-model ;
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
: editor-caret* ( editor -- loc ) editor-caret model-value ;
: editor-caret* ( editor -- loc ) caret>> model-value ;
: editor-mark* ( editor -- loc ) editor-mark model-value ;
: editor-mark* ( editor -- loc ) mark>> model-value ;
: set-caret ( loc editor -- )
[ gadget-model validate-loc ] keep
editor-caret set-model ;
[ model>> validate-loc ] keep
caret>> set-model ;
: change-caret ( editor quot -- )
over >r >r dup editor-caret* swap gadget-model r> call r>
over >r >r dup editor-caret* swap model>> r> call r>
set-caret ; inline
: mark>caret ( editor -- )
dup editor-caret* swap editor-mark set-model ;
dup editor-caret* swap mark>> set-model ;
: change-caret&mark ( editor quot -- )
over >r change-caret r> mark>caret ; inline
: editor-line ( n editor -- str ) control-value nth ;
: editor-font* ( editor -- font ) editor-font open-font ;
: editor-font* ( editor -- font ) font>> open-font ;
: line-height ( editor -- n )
editor-font* "" string-height ;
: y>line ( y editor -- line# )
[ line-height / >fixnum ] keep gadget-model validate-line ;
[ line-height / >fixnum ] keep model>> validate-line ;
: point>loc ( point editor -- loc )
[
@ -96,11 +96,9 @@ M: editor ungraft*
: click-loc ( editor model -- )
>r clicked-loc r> set-model ;
: focus-editor ( editor -- )
t over set-editor-focused? relayout-1 ;
: focus-editor ( editor -- ) t over (>>focused?) relayout-1 ;
: unfocus-editor ( editor -- )
f over set-editor-focused? relayout-1 ;
: unfocus-editor ( editor -- ) f over (>>focused?) relayout-1 ;
: (offset>x) ( font col# str -- x )
swap head-slice string-width ;
@ -121,15 +119,15 @@ M: editor ungraft*
line-height 0 swap 2array ;
: scroll>caret ( editor -- )
dup gadget-graft-state second [
dup graft-state>> second [
dup caret-loc over caret-dim { 1 0 } v+ <rect>
over scroll>rect
] when drop ;
: draw-caret ( -- )
editor get editor-focused? [
editor get focused?>> [
editor get
dup editor-caret-color set-color
dup caret-color>> set-color
dup caret-loc origin get v+
swap caret-dim over v+
[ { 0.5 -0.5 } v+ ] bi@ gl-line
@ -142,7 +140,7 @@ M: editor ungraft*
line-translation gl-translate ;
: draw-line ( editor str -- )
>r editor-font r> { 0 0 } draw-string ;
>r font>> r> { 0 0 } draw-string ;
: first-visible-line ( editor -- n )
clip get rect-loc second origin get second -
@ -157,7 +155,7 @@ M: editor ungraft*
swap
dup first-visible-line \ first-visible-line set
dup last-visible-line \ last-visible-line set
dup gadget-model document set
dup model>> document set
editor set
call
] with-scope ; inline
@ -173,7 +171,7 @@ M: editor ungraft*
: draw-lines ( -- )
\ first-visible-line get [
editor get dup editor-color set-color
editor get dup color>> set-color
dup visible-lines
[ draw-line 1 translate-lines ] with each
] with-editor-translation ;
@ -192,7 +190,7 @@ M: editor ungraft*
(draw-selection) ;
: draw-selection ( -- )
editor get editor-selection-color set-color
editor get selection-color>> set-color
editor get selection-start/end
over first [
2dup [
@ -227,24 +225,24 @@ M: editor gadget-selection?
selection-start/end = not ;
M: editor gadget-selection
[ selection-start/end ] keep gadget-model doc-range ;
[ selection-start/end ] keep model>> doc-range ;
: remove-selection ( editor -- )
[ selection-start/end ] keep gadget-model remove-doc-range ;
[ selection-start/end ] keep model>> remove-doc-range ;
M: editor user-input*
[ selection-start/end ] keep gadget-model set-doc-range t ;
[ selection-start/end ] keep model>> set-doc-range t ;
: editor-string ( editor -- string )
gadget-model doc-string ;
model>> doc-string ;
: set-editor-string ( string editor -- )
gadget-model set-doc-string ;
model>> set-doc-string ;
M: editor gadget-text* editor-string % ;
: extend-selection ( editor -- )
dup request-focus dup editor-caret click-loc ;
dup request-focus dup caret>> click-loc ;
: mouse-elt ( -- element )
hand-click# get {
@ -257,12 +255,12 @@ M: editor gadget-text* editor-string % ;
: drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep
gadget-model
model>>
r> prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc )
>r [ drag-direction? not ] 2keep
nip dup editor-mark* swap gadget-model
nip dup editor-mark* swap model>>
r> prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
@ -272,8 +270,8 @@ M: editor gadget-text* editor-string % ;
: drag-selection ( editor -- )
dup drag-caret&mark
pick editor-mark set-model
swap editor-caret set-model ;
pick mark>> set-model
swap caret>> set-model ;
: editor-cut ( editor clipboard -- )
dupd gadget-copy remove-selection ;
@ -282,8 +280,8 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [
drop nip remove-selection
] [
over >r >r dup editor-caret* swap gadget-model
r> call r> gadget-model remove-doc-range
over >r >r dup editor-caret* swap model>>
r> call r> model>> remove-doc-range
] if ; inline
: editor-delete ( editor elt -- )
@ -305,11 +303,11 @@ M: editor gadget-text* editor-string % ;
dupd editor-select-next mark>caret ;
: editor-select ( from to editor -- )
tuck editor-caret set-model editor-mark set-model ;
tuck caret>> set-model mark>> set-model ;
: select-elt ( editor elt -- )
over >r
>r dup editor-caret* swap gadget-model r> prev/next-elt
>r dup editor-caret* swap model>> r> prev/next-elt
r> editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
@ -318,7 +316,7 @@ M: editor gadget-text* editor-string % ;
: position-caret ( editor -- )
mouse-elt dup T{ one-char-elt } =
[ drop dup extend-selection dup editor-mark click-loc ]
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
: insert-newline ( editor -- ) "\n" swap user-input ;

9
basis/ui/gadgets/gadgets-docs.factor
View File

@ -31,7 +31,7 @@ HELP: user-input*
HELP: children-on
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
HELP: pick-up
{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
@ -57,7 +57,7 @@ HELP: gadget-selection
HELP: relayout
{ $values { "gadget" gadget } }
{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $snippet "root?" } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
HELP: relayout-1
{ $values { "gadget" gadget } }
@ -170,7 +170,7 @@ HELP: focusable-child
{ $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
{ control-value set-control-value gadget-model } related-words
{ control-value set-control-value } related-words
HELP: control-value
{ $values { "control" gadget } { "value" object } }
@ -181,10 +181,9 @@ HELP: set-control-value
{ $description "Sets the value of the control's model." } ;
ARTICLE: "ui-control-impl" "Implementing controls"
"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $snippet "model" } " slot set to a " { $link model } " instance."
$nl
"Some utility words useful in control implementations:"
{ $subsection gadget-model }
{ $subsection control-value }
{ $subsection set-control-value }
{ $see-also "models" } ;

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

@ -150,7 +150,7 @@ DEFER: relayout
: invalidate* ( gadget -- )
\ invalidate* over (>>layout-state)
dup forget-pref-dim
dup gadget-root?
dup root?>>
[ layout-later ] [ parent>> [ relayout ] when* ] if ;
: relayout ( gadget -- )

2
basis/ui/gadgets/grid-lines/grid-lines-docs.factor
View File

@ -3,4 +3,4 @@ ui.render ;
IN: ui.gadgets.grid-lines
HELP: grid-lines
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;

6
basis/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces opengl opengl.gl sequences
USING: kernel accessors math namespaces opengl opengl.gl sequences
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
IN: ui.gadgets.grid-lines
@ -10,7 +10,7 @@ C: <grid-lines> grid-lines
SYMBOL: grid-dim
: half-gap grid get grid-gap [ 2/ ] map ; inline
: half-gap grid get gap>> [ 2/ ] map ; inline
: grid-line-from/to ( orientation point -- from to )
half-gap v-
@ -25,7 +25,7 @@ SYMBOL: grid-dim
M: grid-lines draw-boundary
origin get [
-0.5 -0.5 0.0 glTranslated
grid-lines-color set-color [
color>> set-color [
dup grid set
dup rect-dim half-gap v- grid-dim set
compute-grid

4
basis/ui/gadgets/grids/grids-docs.factor
View File

@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
HELP: grid
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
$nl
"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
"The " { $snippet "gap" } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
$nl
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
"The " { $snippet "fill?" } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
$nl
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
$nl

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