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

db4
Joe Groff 2008-08-31 18:48:27 -07:00
commit 6d7e7355a1
31 changed files with 352 additions and 176 deletions

View File

@ -1,14 +1,14 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math strings help.markup help.syntax
calendar.backend ;
calendar.backend math.order ;
IN: calendar
HELP: duration
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers." } ;
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ;
HELP: timestamp
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } "." } ;
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ;
{ timestamp duration } related-words
@ -28,4 +28,168 @@ HELP: <date>
HELP: month-names
{ $values { "array" array } }
{ $description "Returns an array with the English names of all the months. January has a index of 1 instead of 0." } ;
{ $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
HELP: month-name
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
{ $values { "array" array } }
{ $description "Returns an array with the English abbreviated names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
HELP: month-abbreviation
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: day-names
{ $values { "array" array } }
{ $description "Returns an array with the English names of the days of the week." } ;
HELP: day-name
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
{ $values { "array" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3
{ $values { "array" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3
{ $values { "n" integer } { "string" string } }
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is three characters long." } ;
{
day-name day-names
day-abbreviation2 day-abbreviations2
day-abbreviation3 day-abbreviations3
} related-words
HELP: average-month
{ $values { "ratio" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
{ $values { "integer" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
{ $values { "ratio" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
{ $values { "ratio" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
{ $values { "ratio" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
{ $values { "integer" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
{ $warning "Not valid before year -4800 BCE." } ;
HELP: julian-day-number>date
{ $values { "n" integer } { "year" integer } { "month" integer } { "day" integer } }
{ $description "Converts from a Julian day number back to a year, month, and day." } ;
{ julian-day-number julian-day-number>date } related-words
HELP: >date<
{ $values { "timestamp" timestamp } { "year" integer } { "month" integer } { "day" integer } }
{ $description "Explodes a " { $snippet "timestamp" } " into its year, month, and day components." }
{ $examples { $example "USING: arrays calendar prettyprint ;"
"2010 8 24 <date> >date< 3array ."
"{ 2010 8 24 }"
}
} ;
HELP: >time<
{ $values { "timestamp" timestamp } { "hour" integer } { "minute" integer } { "second" integer } }
{ $description "Explodes a " { $snippet "timestamp" } " into its hour, minute, and second components." }
{ $examples { $example "USING: arrays calendar prettyprint ;"
"now noon >time< 3array ."
"{ 12 0 0 }"
}
} ;
{ >date< >time< } related-words
HELP: instant
{ $values { "duration" duration } }
{ $description "Pushes a " { $snippet "duration" } " of zero seconds." } ;
HELP: years
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: months
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: days
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: weeks
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: hours
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: minutes
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: seconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: milliseconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
HELP: leap-year?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Returns " { $link t } " if the object represents a leap year." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"2008 leap-year? ."
"t"
}
{ $example "USING: calendar prettyprint ;"
"2010 1 1 <date> leap-year? ."
"f"
}
} ;
HELP: time+
{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
{ $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." }
{ $examples
{ $example "USING: calendar math.order prettyprint ;"
"10 months 2 months time+ 1 year <=> ."
"+eq+"
}
{ $example "USING: accessors calendar math.order prettyprint ;"
"2010 1 1 <date> 3 days time+ day>> ."
"4"
}
} ;

View File

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

View File

@ -12,8 +12,6 @@ IN: compiler.tree.propagation.info
: null-class? ( class -- ? ) null class<= ;
SYMBOL: +interval+
GENERIC: eql? ( obj1 obj2 -- ? )
M: object eql? eq? ;
M: fixnum eql? eq? ;
@ -40,7 +38,7 @@ slots ;
: class-interval ( class -- interval )
dup real class<=
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
[ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
@ -84,7 +82,7 @@ slots ;
init-value-info ; foldable
: <class-info> ( class -- info )
dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
<class/interval-info> ; foldable
: <interval-info> ( interval -- info )

View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard classes.algebra
classes.union sets quotations assocs combinators words
namespaces
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces
compiler.tree
compiler.tree.builder
compiler.tree.normalization
@ -145,3 +145,13 @@ SYMBOL: history
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
: do-inlining ( #call word -- ? )
{
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;

View File

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

View File

@ -6,9 +6,6 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
SYMBOL: +constraints+
SYMBOL: +outputs+
GENERIC: propagate-before ( node -- )
GENERIC: propagate-after ( node -- )

View File

@ -3,8 +3,7 @@
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays
math math.partial-dispatch math.private slots generic definitions
generic.standard generic.math
math math.private slots generic definitions
stack-checker.state
compiler.tree
compiler.tree.propagation.info
@ -52,7 +51,7 @@ M: #declare propagate-before
with-datastack first assume ;
: compute-constraints ( #call word -- )
dup +constraints+ word-prop [ nip custom-constraints ] [
dup "constraints" word-prop [ nip custom-constraints ] [
dup predicate? [
[ [ in-d>> first ] [ out-d>> first ] bi ]
[ "predicating" word-prop ] bi*
@ -61,19 +60,22 @@ M: #declare propagate-before
] if* ;
: call-outputs-quot ( #call word -- infos )
[ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
[ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
: foldable-call? ( #call word -- ? )
"foldable" word-prop
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
: fold-call ( #call word -- infos )
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
'[ , , with-datastack [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
recover ;
: fold-call ( #call word -- )
[ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
: predicate-output-infos ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
@ -95,30 +97,23 @@ M: #declare propagate-before
: output-value-infos ( #call word -- infos )
{
{ [ 2dup foldable-call? ] [ fold-call ] }
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] }
{ [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;
: do-inlining ( #call word -- ? )
{
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;
M: #call propagate-before
dup word>> 2dup do-inlining [ 2drop ] [
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
[ compute-constraints ]
2bi
] if ;
dup word>> {
{ [ 2dup foldable-call? ] [ fold-call ] }
{ [ 2dup do-inlining ] [ 2drop ] }
[
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
[ compute-constraints ]
2bi
]
} cond ;
M: #call annotate-node
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;

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

View File

@ -1,6 +1,6 @@
USING: definitions help help.topics help.crossref help.markup
help.syntax kernel sequences tools.test words parser namespaces
assocs source-files eval ;
USING: accessors definitions help help.topics help.crossref
help.markup help.syntax kernel sequences tools.test words parser
namespaces assocs source-files eval ;
IN: help.topics.tests
\ article-name must-infer

View File

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

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"

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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