Merge branch 'master' of git://factorcode.org/git/factor
commit
6d7e7355a1
|
@ -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"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue