Merge branch 'master' of git://factorcode.org/git/factor
commit
3fdf30571f
basis
alien/structs
bit-arrays
bit-vectors
bootstrap/image
calendar
channels
checksums
cocoa
compiler
generator
fixup
registers
intrinsics
tree
dead-code/simple
escape-analysis
finalization
normalization
propagation
info
inlining
known-words
nodes
simple
slots
tuple-unboxing
concurrency/distributed
cpu
ppc
x86
intrinsics
db
errors
queries
types
debugger
delegate
editors/gvim
float-arrays
|
@ -9,13 +9,19 @@ HELP: add-alarm
|
|||
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
|
||||
|
||||
HELP: later
|
||||
{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
|
||||
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
|
||||
|
||||
HELP: cancel-alarm
|
||||
{ $values { "alarm" alarm } }
|
||||
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
|
||||
|
||||
HELP: every
|
||||
{ $values
|
||||
{ "quot" quotation } { "duration" duration }
|
||||
{ "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
|
||||
|
||||
ARTICLE: "alarms" "Alarms"
|
||||
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
|
||||
{ $subsection alarm }
|
||||
|
|
|
@ -82,10 +82,10 @@ PRIVATE>
|
|||
: add-alarm ( quot time frequency -- alarm )
|
||||
<alarm> [ register-alarm ] keep ;
|
||||
|
||||
: later ( quot dt -- alarm )
|
||||
: later ( quot duration -- alarm )
|
||||
hence f add-alarm ;
|
||||
|
||||
: every ( quot dt -- alarm )
|
||||
: every ( quot duration -- alarm )
|
||||
[ hence ] keep add-alarm ;
|
||||
|
||||
: cancel-alarm ( alarm -- )
|
||||
|
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel kernel.private math namespaces
|
||||
sequences strings words effects combinators alien.c-types ;
|
||||
IN: alien.structs.fields
|
||||
|
||||
TUPLE: field-spec name offset type reader writer ;
|
||||
|
||||
: reader-effect ( type spec -- effect )
|
||||
[ 1array ] [ name>> 1array ] bi* <effect> ;
|
||||
|
||||
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
|
||||
|
||||
: set-reader-props ( class spec -- )
|
||||
2dup reader-effect
|
||||
over reader>>
|
||||
swap "declared-effect" set-word-prop
|
||||
reader>> swap "reading" set-word-prop ;
|
||||
|
||||
: writer-effect ( type spec -- effect )
|
||||
name>> swap 2array 0 <effect> ;
|
||||
|
||||
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
||||
|
||||
: set-writer-props ( class spec -- )
|
||||
2dup writer-effect
|
||||
over writer>>
|
||||
swap "declared-effect" set-word-prop
|
||||
writer>> swap "writing" set-word-prop ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
>r >r "-" r> 3append r> create ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
>r [ swap "set-" % % "-" % % ] "" make r> create ;
|
||||
|
||||
: <field-spec> ( struct-name vocab type field-name -- spec )
|
||||
field-spec new
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap expand-constants >>type
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
||||
: align-offset ( offset type -- offset )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( specs -- size )
|
||||
0 [
|
||||
[ type>> align-offset ] keep
|
||||
[ (>>offset) ] [ type>> heap-size + ] 2bi
|
||||
] reduce ;
|
||||
|
||||
: define-struct-slot-word ( spec word quot -- )
|
||||
rot offset>> prefix define-inline ;
|
||||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ ]
|
||||
[ reader>> ]
|
||||
[
|
||||
type>>
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append
|
||||
] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-setter ( type spec -- )
|
||||
[ set-writer-props ] keep
|
||||
[ ]
|
||||
[ writer>> ]
|
||||
[ type>> c-setter ] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-field ( type spec -- )
|
||||
[ define-getter ] [ define-setter ] 2bi ;
|
|
@ -1,75 +1,7 @@
|
|||
IN: alien.structs
|
||||
USING: accessors alien.c-types strings help.markup help.syntax
|
||||
alien.syntax sequences io arrays slots.deprecated
|
||||
kernel words slots assocs namespaces accessors ;
|
||||
|
||||
! Deprecated code
|
||||
: ($spec-reader-values) ( slot-spec class -- element )
|
||||
dup ?word-name swap 2array
|
||||
over name>>
|
||||
rot class>> 2array 2array
|
||||
[ { $instance } swap suffix ] assoc-map ;
|
||||
|
||||
: $spec-reader-values ( slot-spec class -- )
|
||||
($spec-reader-values) $values ;
|
||||
|
||||
: $spec-reader-description ( slot-spec class -- )
|
||||
[
|
||||
"Outputs the value stored in the " ,
|
||||
{ $snippet } rot name>> suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
: slot-of-reader ( reader specs -- spec/f )
|
||||
[ reader>> eq? ] with find nip ;
|
||||
|
||||
: $spec-reader ( reader slot-specs class -- )
|
||||
>r slot-of-reader r>
|
||||
over [
|
||||
2dup $spec-reader-values
|
||||
2dup $spec-reader-description
|
||||
] when 2drop ;
|
||||
|
||||
GENERIC: slot-specs ( help-type -- specs )
|
||||
|
||||
M: word slot-specs "slots" word-prop ;
|
||||
|
||||
: $slot-reader ( reader -- )
|
||||
first dup "reading" word-prop [ slot-specs ] keep
|
||||
$spec-reader ;
|
||||
|
||||
: $spec-writer-values ( slot-spec class -- )
|
||||
($spec-reader-values) reverse $values ;
|
||||
|
||||
: $spec-writer-description ( slot-spec class -- )
|
||||
[
|
||||
"Stores a new value to the " ,
|
||||
{ $snippet } rot name>> suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
: slot-of-writer ( writer specs -- spec/f )
|
||||
[ writer>> eq? ] with find nip ;
|
||||
|
||||
: $spec-writer ( writer slot-specs class -- )
|
||||
>r slot-of-writer r>
|
||||
over [
|
||||
2dup $spec-writer-values
|
||||
2dup $spec-writer-description
|
||||
dup ?word-name 1array $side-effects
|
||||
] when 2drop ;
|
||||
|
||||
: $slot-writer ( reader -- )
|
||||
first dup "writing" word-prop [ slot-specs ] keep
|
||||
$spec-writer ;
|
||||
|
||||
M: string slot-specs c-type fields>> ;
|
||||
|
||||
M: array ($instance) first ($instance) " array" write ;
|
||||
alien.syntax sequences io arrays kernel words assocs namespaces
|
||||
accessors ;
|
||||
IN: alien.structs
|
||||
|
||||
ARTICLE: "c-structs" "C structure types"
|
||||
"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
|
||||
|
|
|
@ -1,43 +1,10 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc slots
|
||||
slots.deprecated alien.c-types cpu.architecture ;
|
||||
math namespaces parser sequences strings words libc
|
||||
alien.c-types alien.structs.fields cpu.architecture ;
|
||||
IN: alien.structs
|
||||
|
||||
: align-offset ( offset type -- offset )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( specs -- size )
|
||||
0 [
|
||||
[ class>> align-offset ] keep
|
||||
[ (>>offset) ] 2keep
|
||||
class>> heap-size +
|
||||
] reduce ;
|
||||
|
||||
: define-struct-slot-word ( spec word quot -- )
|
||||
rot offset>> prefix define-inline ;
|
||||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ ]
|
||||
[ reader>> ]
|
||||
[
|
||||
class>>
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append
|
||||
] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-setter ( type spec -- )
|
||||
[ set-writer-props ] keep
|
||||
[ ]
|
||||
[ writer>> ]
|
||||
[ class>> c-setter ] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-field ( type spec -- )
|
||||
2dup define-getter define-setter ;
|
||||
|
||||
: if-value-structs? ( ctype true false -- )
|
||||
value-structs?
|
||||
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
|
||||
|
@ -76,17 +43,8 @@ M: struct-type stack-size
|
|||
struct-type boa
|
||||
-rot define-c-type ;
|
||||
|
||||
: make-field ( struct-name vocab type field-name -- spec )
|
||||
<slot-spec>
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap expand-constants >>class
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
||||
: define-struct-early ( name vocab fields -- fields )
|
||||
-rot [ rot first2 make-field ] 2curry map ;
|
||||
-rot [ rot first2 <field-spec> ] 2curry map ;
|
||||
|
||||
: compute-struct-align ( types -- n )
|
||||
[ c-type-align ] map supremum ;
|
||||
|
@ -94,7 +52,7 @@ M: struct-type stack-size
|
|||
: define-struct ( name vocab fields -- )
|
||||
pick >r
|
||||
[ struct-offsets ] keep
|
||||
[ [ class>> ] map compute-struct-align ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
r> [ swap define-field ] curry each ;
|
||||
|
||||
|
|
|
@ -91,5 +91,5 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
INSTANCE: bit-array sequence
|
||||
|
||||
M: bit-array pprint-delims drop \ ?{ \ } ;
|
||||
|
||||
M: bit-array >pprint-sequence ;
|
||||
M: bit-array pprint* pprint-object ;
|
||||
|
|
|
@ -34,5 +34,5 @@ INSTANCE: bit-vector growable
|
|||
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
|
||||
|
||||
M: bit-vector >pprint-sequence ;
|
||||
|
||||
M: bit-vector pprint-delims drop \ ?V{ \ } ;
|
||||
M: bit-vector pprint* pprint-object ;
|
||||
|
|
|
@ -358,7 +358,7 @@ M: byte-array '
|
|||
|
||||
! Tuples
|
||||
: (emit-tuple) ( tuple -- pointer )
|
||||
[ tuple>array rest-slice ]
|
||||
[ tuple-slots ]
|
||||
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
|
||||
tuple type-number dup [ emit-seq ] emit-object ;
|
||||
|
||||
|
@ -384,9 +384,9 @@ M: tuple-layout '
|
|||
] cache-object ;
|
||||
|
||||
M: tombstone '
|
||||
delegate
|
||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||
def>> first [ emit-tuple ] cache-object ;
|
||||
state>> "((tombstone))" "((empty))" ?
|
||||
"hashtables.private" lookup def>> first
|
||||
[ emit-tuple ] cache-object ;
|
||||
|
||||
! Arrays
|
||||
M: array '
|
||||
|
|
|
@ -1,4 +0,0 @@
|
|||
USING: kernel system ;
|
||||
IN: calendar.backend
|
||||
|
||||
HOOK: gmt-offset os ( -- hours minutes seconds )
|
|
@ -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 math.order ;
|
||||
math.order ;
|
||||
IN: calendar
|
||||
|
||||
HELP: duration
|
||||
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ;
|
||||
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
|
||||
|
||||
HELP: timestamp
|
||||
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ;
|
||||
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ;
|
||||
|
||||
{ timestamp duration } related-words
|
||||
|
||||
|
@ -21,8 +21,8 @@ HELP: <date>
|
|||
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"12 25 2010 <date> ."
|
||||
"T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }"
|
||||
"2010 12 25 <date> ."
|
||||
"T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
@ -135,43 +135,37 @@ HELP: instant
|
|||
|
||||
HELP: years
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ year years } related-words
|
||||
{ $description "Creates a duration object with the specified number of years." } ;
|
||||
|
||||
HELP: months
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ month months } related-words
|
||||
{ $description "Creates a duration object with the specified number of months." } ;
|
||||
|
||||
HELP: days
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ day days } related-words
|
||||
{ $description "Creates a duration object with the specified number of days." } ;
|
||||
|
||||
HELP: weeks
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ week weeks } related-words
|
||||
{ $description "Creates a duration object with the specified number of weeks." } ;
|
||||
|
||||
HELP: hours
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ hour hours } related-words
|
||||
{ $description "Creates a duration object with the specified number of hours." } ;
|
||||
|
||||
HELP: minutes
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ minute minutes } related-words
|
||||
{ $description "Creates a duration object with the specified number of minutes." } ;
|
||||
|
||||
HELP: seconds
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ second seconds } related-words
|
||||
{ $description "Creates a duration object with the specified number of seconds." } ;
|
||||
|
||||
HELP: milliseconds
|
||||
{ $values { "x" number } { "duration" duration } }
|
||||
{ $description } ;
|
||||
{ millisecond milliseconds } related-words
|
||||
{ $description "Creates a duration object with the specified number of milliseconds." } ;
|
||||
|
||||
{ years months days hours minutes seconds milliseconds } related-words
|
||||
|
||||
HELP: leap-year?
|
||||
{ $values { "obj" object } { "?" "a boolean" } }
|
||||
|
@ -192,7 +186,7 @@ HELP: time+
|
|||
{ $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 <=> ."
|
||||
"10 months 2 months time+ 1 years <=> ."
|
||||
"+eq+"
|
||||
}
|
||||
{ $example "USING: accessors calendar math.order prettyprint ;"
|
||||
|
@ -201,3 +195,412 @@ HELP: time+
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: duration>years
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in years." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 months duration>years ."
|
||||
"1/2"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: duration>months
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in months." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"30 days duration>months ."
|
||||
"16000/16233"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: duration>days
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in days." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 hours duration>days ."
|
||||
"1/4"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: duration>hours
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in hours." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"3/4 days duration>hours ."
|
||||
"18"
|
||||
}
|
||||
} ;
|
||||
HELP: duration>minutes
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in minutes." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 hours duration>minutes ."
|
||||
"360"
|
||||
}
|
||||
} ;
|
||||
HELP: duration>seconds
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in seconds." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 minutes duration>seconds ."
|
||||
"360"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: duration>milliseconds
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in milliseconds." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 seconds duration>milliseconds ."
|
||||
"6000"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words
|
||||
|
||||
|
||||
HELP: time-
|
||||
{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
|
||||
{ $description "Subtracts two durations to produce a duration or subtracts a duration from a timestamp to produce a timestamp. The calculation takes timezones into account." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar math.order prettyprint ;"
|
||||
"10 months 2 months time- 8 months <=> ."
|
||||
"+eq+"
|
||||
}
|
||||
{ $example "USING: accessors calendar math.order prettyprint ;"
|
||||
"2010 1 1 <date> 3 days time- day>> ."
|
||||
"29"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: convert-timezone
|
||||
{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
|
||||
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar prettyprint ;"
|
||||
"gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ."
|
||||
"-5"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: >local-time
|
||||
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
|
||||
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar kernel prettyprint ;"
|
||||
"now gmt >local-time [ gmt-offset>> ] bi@ = ."
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: >gmt
|
||||
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
|
||||
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar kernel prettyprint ;"
|
||||
"now >gmt gmt-offset>> hour>> ."
|
||||
"0"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: time*
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } }
|
||||
{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ;
|
||||
{ time+ time- time* } related-words
|
||||
|
||||
HELP: before
|
||||
{ $values { "duration" duration } { "-duration" duration } }
|
||||
{ $description "Negates a duration." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar prettyprint ;"
|
||||
"3 hours before now noon time+ hour>> ."
|
||||
"9"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <zero>
|
||||
{ $values { "timestamp" timestamp } }
|
||||
{ $description "Outputs a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
|
||||
|
||||
HELP: valid-timestamp?
|
||||
{ $values { "timestamp" timestamp } { "?" "a boolean" } }
|
||||
{ $description "Tests if a timestamp is valid or not." } ;
|
||||
|
||||
HELP: unix-1970
|
||||
{ $values { "timestamp" timestamp } }
|
||||
{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
|
||||
|
||||
HELP: millis>timestamp
|
||||
{ $values { "x" number } { "timestamp" timestamp } }
|
||||
{ $description "Converts a number of milliseconds into a timestamp value in GMT time." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar prettyprint ;"
|
||||
"1000 millis>timestamp year>> ."
|
||||
"1970"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: gmt
|
||||
{ $values { "timestamp" timestamp } }
|
||||
{ $description "Outputs the time right now, but in the GMT timezone." } ;
|
||||
|
||||
{ gmt now } related-words
|
||||
|
||||
HELP: now
|
||||
{ $values { "timestamp" timestamp } }
|
||||
{ $description "Outputs the time right now in your computer's timezone." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: calendar prettyprint ;"
|
||||
"now ."
|
||||
"T{ timestamp f 2008 9 1 16 38 24+801/1000 T{ duration f 0 0 0 -5 0 0 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: hence
|
||||
{ $values { "duration" duration } { "timestamp" timestamp } }
|
||||
{ $description "Computes a time in the future that is the " { $snippet "duration" } " added to the result of " { $link now } "." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: calendar prettyprint ;"
|
||||
"10 hours hence ."
|
||||
"T{ timestamp f 2008 9 2 2 47 45+943/1000 T{ duration f 0 0 0 -5 0 0 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ago
|
||||
{ $values { "duration" duration } { "timestamp" timestamp } }
|
||||
{ $description "Computes a time in the past that is the " { $snippet "duration" } " subtracted from the result of " { $link now } "." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: calendar prettyprint ;"
|
||||
"3 weeks ago ."
|
||||
"T{ timestamp f 2008 8 11 16 49 52+99/500 T{ duration f 0 0 0 -5 0 0 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: zeller-congruence
|
||||
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
|
||||
{ $description "An implementation of an algorithm that computes the day of the week given a date. Days are indexed starting from Sunday, which is index 0." }
|
||||
{ $notes "User code should use the " { $link day-of-week } " word, which takes a " { $snippet "timestamp" } " instead of integers." } ;
|
||||
|
||||
HELP: days-in-year
|
||||
{ $values { "obj" "a timestamp or an integer" } { "n" integer } }
|
||||
{ $description "Calculates the number of days in a given year." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"2004 days-in-year ."
|
||||
"366"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: days-in-month
|
||||
{ $values { "timestamp" timestamp } { "n" integer } }
|
||||
{ $description "Calculates the number of days in a given month." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"2008 8 24 <date> days-in-month ."
|
||||
"31"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: day-of-week
|
||||
{ $values { "timestamp" timestamp } { "n" integer } }
|
||||
{ $description "Calculates the index of the day of the week. Sunday will result in an index of 0." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"now sunday day-of-week ."
|
||||
"0"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: day-of-year
|
||||
{ $values { "timestamp" timestamp } { "n" integer } }
|
||||
{ $description "Calculates the day of the year, resulting in a number from 1 to 366 (leap years)." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"2008 1 4 <date> day-of-year ."
|
||||
"4"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: sunday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Sunday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
HELP: monday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Monday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
HELP: tuesday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Tuesday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
HELP: wednesday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Wednesday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
HELP: thursday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Thursday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
HELP: friday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Friday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
HELP: saturday
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns the Saturday from the current week, which starts on a Sunday." } ;
|
||||
|
||||
{ sunday monday tuesday wednesday thursday friday saturday } related-words
|
||||
|
||||
HELP: midnight
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns a timestamp that represents today at midnight, or the beginning of the day." } ;
|
||||
|
||||
HELP: noon
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Returns a timestamp that represents today at noon, or the middle of the day." } ;
|
||||
|
||||
HELP: beginning-of-month
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Outputs a timestamp with the day set to one." } ;
|
||||
|
||||
HELP: beginning-of-week
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Outputs a timestamp where the day of the week is Sunday." } ;
|
||||
|
||||
HELP: beginning-of-year
|
||||
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
|
||||
{ $description "Outputs a timestamp with the month and day set to one, or January 1 of the input timestamp." } ;
|
||||
|
||||
HELP: time-since-midnight
|
||||
{ $values { "timestamp" timestamp } { "duration" duration } }
|
||||
{ $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
|
||||
|
||||
ARTICLE: "calendar" "Calendar"
|
||||
"The two data types used throughout the calendar library:"
|
||||
{ $subsection timestamp }
|
||||
{ $subsection duration }
|
||||
"Durations represent spans of time:"
|
||||
{ $subsection "using-durations" }
|
||||
"Arithmetic on timestamps and durations:"
|
||||
{ $subsection "timestamp-arithmetic" }
|
||||
"Getting the current timestamp:"
|
||||
{ $subsection now }
|
||||
{ $subsection gmt }
|
||||
"Converting between timestamps:"
|
||||
{ $subsection >local-time }
|
||||
{ $subsection >gmt }
|
||||
"Converting between timezones:"
|
||||
{ $subsection convert-timezone }
|
||||
"Timestamps relative to each other:"
|
||||
{ $subsection "relative-timestamps" }
|
||||
"Operations on units of time:"
|
||||
{ $subsection "years" }
|
||||
{ $subsection "months" }
|
||||
{ $subsection "days" }
|
||||
"Meta-data about the calendar:"
|
||||
{ $subsection "calendar-facts" }
|
||||
;
|
||||
|
||||
ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic"
|
||||
"Adding timestamps and durations, or durations and durations:"
|
||||
{ $subsection time+ }
|
||||
"Subtracting:"
|
||||
{ $subsection time- }
|
||||
"Element-wise multiplication:"
|
||||
{ $subsection time* } ;
|
||||
|
||||
ARTICLE: "using-durations" "Using durations"
|
||||
"Creating a duration object:"
|
||||
{ $subsection years }
|
||||
{ $subsection months }
|
||||
{ $subsection weeks }
|
||||
{ $subsection days }
|
||||
{ $subsection hours }
|
||||
{ $subsection minutes }
|
||||
{ $subsection seconds }
|
||||
{ $subsection milliseconds }
|
||||
{ $subsection instant }
|
||||
"Converting a duration to a number:"
|
||||
{ $subsection duration>years }
|
||||
{ $subsection duration>months }
|
||||
{ $subsection duration>days }
|
||||
{ $subsection duration>hours }
|
||||
{ $subsection duration>minutes }
|
||||
{ $subsection duration>seconds }
|
||||
{ $subsection duration>milliseconds } ;
|
||||
|
||||
ARTICLE: "relative-timestamps" "Relative timestamps"
|
||||
"In the future:"
|
||||
{ $subsection hence }
|
||||
"In the past:"
|
||||
{ $subsection ago }
|
||||
"Invert a duration:"
|
||||
{ $subsection before }
|
||||
"Days of the week relative to " { $link now } ":"
|
||||
{ $subsection sunday }
|
||||
{ $subsection monday }
|
||||
{ $subsection tuesday }
|
||||
{ $subsection wednesday }
|
||||
{ $subsection thursday }
|
||||
{ $subsection friday }
|
||||
{ $subsection saturday }
|
||||
"New timestamps relative to calendar events:"
|
||||
{ $subsection beginning-of-year }
|
||||
{ $subsection beginning-of-month }
|
||||
{ $subsection beginning-of-week }
|
||||
{ $subsection midnight }
|
||||
{ $subsection noon }
|
||||
;
|
||||
|
||||
ARTICLE: "days" "Day operations"
|
||||
"Naming days:"
|
||||
{ $subsection day-abbreviation2 }
|
||||
{ $subsection day-abbreviations2 }
|
||||
{ $subsection day-abbreviation3 }
|
||||
{ $subsection day-abbreviations3 }
|
||||
{ $subsection day-name }
|
||||
{ $subsection day-names }
|
||||
"Calculating a Julian day number:"
|
||||
{ $subsection julian-day-number }
|
||||
"Calculate a timestamp:"
|
||||
{ $subsection julian-day-number>date }
|
||||
;
|
||||
|
||||
ARTICLE: "calendar-facts" "Calendar facts"
|
||||
"Calendar facts:"
|
||||
{ $subsection average-month }
|
||||
{ $subsection months-per-year }
|
||||
{ $subsection days-per-year }
|
||||
{ $subsection hours-per-year }
|
||||
{ $subsection minutes-per-year }
|
||||
{ $subsection seconds-per-year }
|
||||
{ $subsection days-in-month }
|
||||
{ $subsection day-of-year }
|
||||
{ $subsection day-of-week }
|
||||
;
|
||||
|
||||
ARTICLE: "years" "Year operations"
|
||||
"Leap year predicate:"
|
||||
{ $subsection leap-year? }
|
||||
"Find the number of days in a year:"
|
||||
{ $subsection days-in-year }
|
||||
;
|
||||
|
||||
ARTICLE: "months" "Month operations"
|
||||
"Naming months:"
|
||||
{ $subsection month-name }
|
||||
{ $subsection month-names }
|
||||
{ $subsection month-abbreviation }
|
||||
{ $subsection month-abbreviations }
|
||||
;
|
||||
|
||||
ABOUT: "calendar"
|
||||
|
|
|
@ -33,8 +33,8 @@ IN: calendar.tests
|
|||
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 instant <timestamp> = ] unit-test
|
||||
[ +eq+ ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 instant <timestamp> <=> ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
|
||||
|
|
|
@ -1,11 +1,13 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.functions namespaces sequences
|
||||
strings system vocabs.loader calendar.backend threads
|
||||
accessors combinators locals classes.tuple math.order
|
||||
memoize summary combinators.short-circuit alias ;
|
||||
strings system vocabs.loader threads accessors combinators
|
||||
locals classes.tuple math.order summary
|
||||
combinators.short-circuit ;
|
||||
IN: calendar
|
||||
|
||||
HOOK: gmt-offset os ( -- hours minutes seconds )
|
||||
|
||||
TUPLE: duration
|
||||
{ year real }
|
||||
{ month real }
|
||||
|
@ -60,6 +62,8 @@ PRIVATE>
|
|||
: month-abbreviation ( n -- string )
|
||||
check-month 1- month-abbreviations nth ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
|
||||
|
||||
: day-names ( -- array )
|
||||
{
|
||||
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
|
||||
|
@ -116,7 +120,7 @@ PRIVATE>
|
|||
: >time< ( timestamp -- hour minute second )
|
||||
[ hour>> ] [ minute>> ] [ second>> ] tri ;
|
||||
|
||||
MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
|
||||
: 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 ;
|
||||
|
@ -125,14 +129,6 @@ MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
|
|||
: minutes ( x -- duration ) instant clone swap >>minute ;
|
||||
: seconds ( x -- duration ) instant clone swap >>second ;
|
||||
: milliseconds ( x -- duration ) 1000 / seconds ;
|
||||
ALIAS: year years
|
||||
ALIAS: month months
|
||||
ALIAS: day days
|
||||
ALIAS: week weeks
|
||||
ALIAS: hour hours
|
||||
ALIAS: minute minutes
|
||||
ALIAS: second seconds
|
||||
ALIAS: millisecond milliseconds
|
||||
|
||||
GENERIC: leap-year? ( obj -- ? )
|
||||
|
||||
|
@ -244,7 +240,7 @@ M: duration time+
|
|||
2drop <duration>
|
||||
] if ;
|
||||
|
||||
: dt>years ( duration -- x )
|
||||
: duration>years ( duration -- x )
|
||||
#! Uses average month/year length since duration loses calendar
|
||||
#! data
|
||||
0 swap
|
||||
|
@ -257,16 +253,16 @@ M: duration time+
|
|||
[ second>> seconds-per-year / + ]
|
||||
} cleave ;
|
||||
|
||||
M: duration <=> [ dt>years ] compare ;
|
||||
M: duration <=> [ duration>years ] compare ;
|
||||
|
||||
: dt>months ( duration -- x ) dt>years months-per-year * ;
|
||||
: dt>days ( duration -- x ) dt>years days-per-year * ;
|
||||
: dt>hours ( duration -- x ) dt>years hours-per-year * ;
|
||||
: dt>minutes ( duration -- x ) dt>years minutes-per-year * ;
|
||||
: dt>seconds ( duration -- x ) dt>years seconds-per-year * ;
|
||||
: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ;
|
||||
: duration>months ( duration -- x ) duration>years months-per-year * ;
|
||||
: duration>days ( duration -- x ) duration>years days-per-year * ;
|
||||
: duration>hours ( duration -- x ) duration>years hours-per-year * ;
|
||||
: duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
|
||||
: duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
|
||||
: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ;
|
||||
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
GENERIC: time- ( time1 time2 -- time3 )
|
||||
|
||||
: convert-timezone ( timestamp duration -- timestamp )
|
||||
over gmt-offset>> over = [ drop ] [
|
||||
|
@ -310,17 +306,17 @@ M: timestamp time-
|
|||
M: duration time-
|
||||
before time+ ;
|
||||
|
||||
MEMO: <zero> ( -- timestamp )
|
||||
0 0 0 0 0 0 instant <timestamp> ;
|
||||
: <zero> ( -- timestamp )
|
||||
0 0 0 0 0 0 instant <timestamp> ;
|
||||
|
||||
: valid-timestamp? ( timestamp -- ? )
|
||||
clone instant >>gmt-offset
|
||||
dup <zero> time- <zero> time+ = ;
|
||||
|
||||
MEMO: unix-1970 ( -- timestamp )
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 instant <timestamp> ;
|
||||
|
||||
: millis>timestamp ( n -- timestamp )
|
||||
: millis>timestamp ( x -- timestamp )
|
||||
>r unix-1970 r> milliseconds time+ ;
|
||||
|
||||
: timestamp>millis ( timestamp -- n )
|
||||
|
@ -331,12 +327,9 @@ MEMO: unix-1970 ( -- timestamp )
|
|||
unix-1970 millis milliseconds time+ ;
|
||||
|
||||
: now ( -- timestamp ) gmt >local-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
|
||||
|
||||
: zeller-congruence ( year month day -- n )
|
||||
#! Zeller Congruence
|
||||
#! http://web.textfiles.com/computers/formulas.txt
|
||||
|
@ -371,19 +364,21 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
|||
: day-of-year ( timestamp -- n )
|
||||
>date< (day-of-year) ;
|
||||
|
||||
<PRIVATE
|
||||
: day-offset ( timestamp m -- timestamp n )
|
||||
over day-of-week - ; inline
|
||||
|
||||
: day-this-week ( timestamp n -- timestamp )
|
||||
day-offset days time+ ;
|
||||
PRIVATE>
|
||||
|
||||
: sunday ( timestamp -- timestamp ) 0 day-this-week ;
|
||||
: monday ( timestamp -- timestamp ) 1 day-this-week ;
|
||||
: tuesday ( timestamp -- timestamp ) 2 day-this-week ;
|
||||
: wednesday ( timestamp -- timestamp ) 3 day-this-week ;
|
||||
: thursday ( timestamp -- timestamp ) 4 day-this-week ;
|
||||
: friday ( timestamp -- timestamp ) 5 day-this-week ;
|
||||
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
|
||||
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
|
||||
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
|
||||
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
|
||||
: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
|
||||
: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
|
||||
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
|
||||
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
|
||||
|
||||
: midnight ( timestamp -- new-timestamp )
|
||||
clone 0 >>hour 0 >>minute 0 >>second ; inline
|
||||
|
@ -403,7 +398,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
|||
: time-since-midnight ( timestamp -- duration )
|
||||
dup midnight time- ;
|
||||
|
||||
|
||||
M: timestamp sleep-until timestamp>millis sleep-until ;
|
||||
|
||||
M: duration sleep hence sleep-until ;
|
||||
|
|
|
@ -3,23 +3,23 @@ io.streams.string accessors io math.order ;
|
|||
IN: calendar.format.tests
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
|
||||
"Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
"+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
|
||||
"+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
|
||||
] unit-test
|
||||
|
||||
[ -1 ] [
|
||||
"-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
|
||||
"-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
|
||||
] unit-test
|
||||
|
||||
[ -1-1/2 ] [
|
||||
"-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
|
||||
"-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
|
||||
] unit-test
|
||||
|
||||
[ 1+1/2 ] [
|
||||
"+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
|
||||
"+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
|
||||
] unit-test
|
||||
|
||||
[ ] [ now timestamp>rfc3339 drop ] unit-test
|
||||
|
@ -58,7 +58,7 @@ IN: calendar.format.tests
|
|||
26
|
||||
0
|
||||
37
|
||||
42.12345
|
||||
42+2469/20000
|
||||
T{ duration f 0 0 0 -5 0 0 }
|
||||
}
|
||||
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types arrays calendar.backend
|
||||
kernel structs math unix.time namespaces system ;
|
||||
USING: alien alien.c-types arrays calendar kernel structs
|
||||
math unix.time namespaces system ;
|
||||
IN: calendar.unix
|
||||
|
||||
: get-time ( -- alien )
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: calendar.backend namespaces alien.c-types system
|
||||
windows windows.kernel32 kernel math combinators ;
|
||||
USING: calendar namespaces alien.c-types system windows
|
||||
windows.kernel32 kernel math combinators ;
|
||||
IN: calendar.windows
|
||||
|
||||
M: windows gmt-offset ( -- hours minutes seconds )
|
||||
|
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Channels - based on ideas from newsqueak
|
||||
USING: kernel sequences sequences.lib threads continuations
|
||||
random math accessors ;
|
||||
USING: kernel sequences threads continuations
|
||||
random math accessors random ;
|
||||
IN: channels
|
||||
|
||||
TUPLE: channel receivers senders ;
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
! Remote Channels
|
||||
USING: kernel init namespaces assocs arrays random
|
||||
sequences channels match concurrency.messaging
|
||||
concurrency.distributed threads ;
|
||||
concurrency.distributed threads accessors ;
|
||||
IN: channels.remote
|
||||
|
||||
<PRIVATE
|
||||
|
@ -52,13 +52,13 @@ TUPLE: remote-channel node id ;
|
|||
C: <remote-channel> remote-channel
|
||||
|
||||
M: remote-channel to ( value remote-channel -- )
|
||||
[ [ \ to , remote-channel-id , , ] { } make ] keep
|
||||
remote-channel-node "remote-channels" <remote-process>
|
||||
[ [ \ to , id>> , , ] { } make ] keep
|
||||
node>> "remote-channels" <remote-process>
|
||||
send-synchronous no-channel = [ no-channel throw ] when ;
|
||||
|
||||
M: remote-channel from ( remote-channel -- value )
|
||||
[ [ \ from , remote-channel-id , ] { } make ] keep
|
||||
remote-channel-node "remote-channels" <remote-process>
|
||||
[ [ \ from , id>> , ] { } make ] keep
|
||||
node>> "remote-channels" <remote-process>
|
||||
send-synchronous dup no-channel = [ no-channel throw ] when* ;
|
||||
|
||||
[
|
||||
|
|
0
basis/calendar/backend/authors.txt → basis/checksums/common/authors.txt
Executable file → Normal file
0
basis/calendar/backend/authors.txt → basis/checksums/common/authors.txt
Executable file → Normal file
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.bitwise strings io.binary namespaces
|
||||
grouping ;
|
||||
IN: checksums.common
|
||||
|
||||
SYMBOL: bytes-read
|
||||
|
||||
: calculate-pad-length ( length -- pad-length )
|
||||
dup 56 < 55 119 ? swap - ;
|
||||
|
||||
: pad-last-block ( str big-endian? length -- str )
|
||||
[
|
||||
rot %
|
||||
HEX: 80 ,
|
||||
dup HEX: 3f bitand calculate-pad-length 0 <string> %
|
||||
3 shift 8 rot [ >be ] [ >le ] if %
|
||||
] "" make 64 group ;
|
||||
|
||||
: update-old-new ( old new -- )
|
||||
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
|
|
@ -0,0 +1 @@
|
|||
Some code shared by MD5, SHA1 and SHA2 implementations
|
|
@ -1,11 +1,14 @@
|
|||
! See http://www.faqs.org/rfcs/rfc1321.html
|
||||
|
||||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io io.binary io.files io.streams.byte-array math
|
||||
math.functions math.parser namespaces splitting grouping strings
|
||||
sequences crypto.common byte-arrays locals sequences.private
|
||||
io.encodings.binary symbols math.bitfields.lib checksums ;
|
||||
sequences byte-arrays locals sequences.private
|
||||
io.encodings.binary symbols math.bitwise checksums
|
||||
checksums.common ;
|
||||
IN: checksums.md5
|
||||
|
||||
! See http://www.faqs.org/rfcs/rfc1321.html
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||
|
|
|
@ -1,7 +1,9 @@
|
|||
USING: arrays combinators crypto.common kernel io
|
||||
io.encodings.binary io.files io.streams.byte-array math.vectors
|
||||
strings sequences namespaces math parser sequences vectors
|
||||
io.binary hashtables symbols math.bitfields.lib checksums ;
|
||||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel io io.encodings.binary io.files
|
||||
io.streams.byte-array math.vectors strings sequences namespaces
|
||||
math parser sequences assocs grouping vectors io.binary hashtables
|
||||
symbols math.bitwise checksums checksums.common ;
|
||||
IN: checksums.sha1
|
||||
|
||||
! Implemented according to RFC 3174.
|
||||
|
@ -45,6 +47,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
|
|||
{ 3 [ bitxor bitxor ] }
|
||||
} case ;
|
||||
|
||||
: nth-int-be ( string n -- int )
|
||||
4 * dup 4 + rot <slice> be> ; inline
|
||||
|
||||
: make-w ( str -- )
|
||||
#! compute w, steps a-b of RFC 3174, section 6.1
|
||||
16 [ nth-int-be w get push ] with each
|
||||
|
@ -113,8 +118,16 @@ INSTANCE: sha1 checksum
|
|||
M: sha1 checksum-stream ( stream -- sha1 )
|
||||
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
|
||||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
: sha1-interleave ( string -- seq )
|
||||
[ zero? ] left-trim
|
||||
[ zero? ] trim-left
|
||||
dup length odd? [ rest ] when
|
||||
seq>2seq [ sha1 checksum-bytes ] bi@
|
||||
2seq>seq ;
|
||||
|
|
|
@ -1,6 +1,8 @@
|
|||
USING: crypto.common kernel splitting grouping
|
||||
math sequences namespaces io.binary symbols
|
||||
math.bitfields.lib checksums ;
|
||||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel splitting grouping math sequences namespaces
|
||||
io.binary symbols math.bitwise checksums checksums.common
|
||||
sbufs strings ;
|
||||
IN: checksums.sha2
|
||||
|
||||
<PRIVATE
|
||||
|
@ -81,6 +83,8 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
|
|||
[ -11 bitroll-32 ] keep
|
||||
-25 bitroll-32 bitxor bitxor ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
|
||||
|
||||
: T1 ( W n -- T1 )
|
||||
[ swap nth ] keep
|
||||
K get nth +
|
||||
|
@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
|
|||
: seq>byte-array ( n seq -- string )
|
||||
[ swap [ >be % ] curry each ] B{ } make ;
|
||||
|
||||
: preprocess-plaintext ( string big-endian? -- padded-string )
|
||||
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
|
||||
>r >sbuf r> over [
|
||||
HEX: 80 ,
|
||||
dup length HEX: 3f bitand
|
||||
calculate-pad-length 0 <string> %
|
||||
length 3 shift 8 rot [ >be ] [ >le ] if %
|
||||
] "" make over push-all ;
|
||||
|
||||
: byte-array>sha2 ( byte-array -- string )
|
||||
t preprocess-plaintext
|
||||
block-size get group [ process-chunk ] each
|
||||
|
|
|
@ -20,10 +20,10 @@ CLASS: {
|
|||
|
||||
test-foo
|
||||
|
||||
[ 1 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102 ] [ "x" get NSRect-h ] unit-test
|
||||
[ 1.0 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2.0 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get NSRect-h ] unit-test
|
||||
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
|
@ -41,7 +41,7 @@ Bar [
|
|||
-> release
|
||||
] compile-call
|
||||
|
||||
[ 1 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102 ] [ "x" get NSRect-h ] unit-test
|
||||
[ 1.0 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2.0 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get NSRect-h ] unit-test
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math cocoa cocoa.messages cocoa.classes
|
||||
sequences math.bitfields ;
|
||||
sequences math.bitwise ;
|
||||
IN: cocoa.windows
|
||||
|
||||
: NSBorderlessWindowMask 0 ; inline
|
||||
|
|
|
@ -27,7 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler"
|
|||
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
|
||||
{ $subsection "compiler-usage" }
|
||||
{ $subsection "compiler-errors" }
|
||||
{ $subsection "optimizer" }
|
||||
{ $subsection "hints" }
|
||||
{ $subsection "generator" } ;
|
||||
|
||||
ABOUT: "compiler"
|
||||
|
|
|
@ -43,8 +43,8 @@ SYMBOL: +failed+
|
|||
[
|
||||
dup crossref?
|
||||
[
|
||||
dependencies get
|
||||
generic-dependencies get
|
||||
dependencies get >alist
|
||||
generic-dependencies get >alist
|
||||
compiled-xref
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays byte-arrays generic assocs hashtables io.binary
|
||||
kernel kernel.private math namespaces sequences words
|
||||
quotations strings alien.accessors alien.strings layouts system
|
||||
combinators math.bitfields words.private cpu.architecture
|
||||
combinators math.bitwise words.private cpu.architecture
|
||||
math.order accessors growable ;
|
||||
IN: compiler.generator.fixup
|
||||
|
||||
|
|
|
@ -647,7 +647,7 @@ UNION: immediate fixnum POSTPONE: f ;
|
|||
|
||||
: phantom-shuffle ( shuffle -- )
|
||||
[ in>> length phantom-datastack get phantom-input ] keep
|
||||
shuffle* phantom-datastack get phantom-append ;
|
||||
shuffle phantom-datastack get phantom-append ;
|
||||
|
||||
: phantom->r ( n -- )
|
||||
phantom-datastack get phantom-input
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel classes.tuple classes.tuple.private math arrays
|
||||
byte-arrays words stack-checker.known-words ;
|
||||
IN: compiler.tree.intrinsics
|
||||
IN: compiler.intrinsics
|
||||
|
||||
: (tuple) ( layout -- tuple )
|
||||
"BUG: missing (tuple) intrinsic" throw ;
|
|
@ -84,6 +84,13 @@ FUNCTION: tiny ffi_test_17 int x ;
|
|||
|
||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
||||
|
||||
: indirect-test-1' ( ptr -- )
|
||||
"int" { } "cdecl" alien-indirect drop ;
|
||||
|
||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||
|
||||
[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
|
||||
|
||||
[ -1 indirect-test-1 ] must-fail
|
||||
|
||||
: indirect-test-2 ( x y ptr -- result )
|
||||
|
@ -102,7 +109,7 @@ unit-test
|
|||
<< "f-stdcall" f "stdcall" add-library >>
|
||||
|
||||
[ f ] [ "f-stdcall" load-library ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
||||
|
||||
: ffi_test_18 ( w x y z -- int )
|
||||
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
|
||||
|
|
|
@ -210,10 +210,10 @@ USE: binary-search.private
|
|||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
slice-from
|
||||
from>>
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ drop dup from>> swap midpoint@ + ]
|
||||
[ dup midpoint@ cut-slice old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
IN: compiler.tests
|
||||
USING: compiler tools.test namespaces sequences
|
||||
kernel.private kernel math continuations continuations.private
|
||||
words splitting grouping sorting ;
|
||||
words splitting grouping sorting accessors ;
|
||||
|
||||
: symbolic-stack-trace ( -- newseq )
|
||||
error-continuation get continuation-call callstack>array
|
||||
error-continuation get call>> callstack>array
|
||||
2 group flip first ;
|
||||
|
||||
: foo ( -- * ) 3 throw 7 ;
|
||||
|
|
|
@ -229,10 +229,6 @@ M: float detect-float ;
|
|||
\ detect-float inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 3 + = ] \ equal? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ]
|
||||
\ fixnum-shift-fast inlined?
|
||||
|
|
|
@ -4,8 +4,9 @@ USING: kernel accessors sequences sequences.deep combinators fry
|
|||
classes.algebra namespaces assocs words math math.private
|
||||
math.partial-dispatch math.intervals classes classes.tuple
|
||||
classes.tuple.private layouts definitions stack-checker.state
|
||||
stack-checker.branches compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
stack-checker.branches
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.branches ;
|
||||
|
|
|
@ -81,11 +81,19 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
|||
drop-values
|
||||
] ;
|
||||
|
||||
: drop-dead-outputs ( node -- nodes )
|
||||
: drop-dead-outputs ( node -- #shuffle )
|
||||
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] contains? ;
|
||||
|
||||
: maybe-drop-dead-outputs ( node -- nodes )
|
||||
dup some-outputs-dead? [
|
||||
dup drop-dead-outputs 2array
|
||||
] when ;
|
||||
|
||||
M: #introduce remove-dead-code* ( #introduce -- nodes )
|
||||
dup drop-dead-outputs 2array ;
|
||||
maybe-drop-dead-outputs ;
|
||||
|
||||
M: #>r remove-dead-code*
|
||||
[ filter-live ] change-out-r
|
||||
|
@ -110,17 +118,9 @@ M: #push remove-dead-code*
|
|||
[ in-d>> #drop remove-dead-code* ]
|
||||
bi ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] contains? ;
|
||||
|
||||
M: #call remove-dead-code*
|
||||
dup dead-flushable-call? [
|
||||
remove-flushable-call
|
||||
] [
|
||||
dup some-outputs-dead? [
|
||||
dup drop-dead-outputs 2array
|
||||
] when
|
||||
] if ;
|
||||
dup dead-flushable-call?
|
||||
[ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
|
||||
|
||||
M: #shuffle remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
|
@ -136,3 +136,9 @@ M: #copy remove-dead-code*
|
|||
M: #terminate remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
[ filter-live ] change-in-r ;
|
||||
|
||||
M: #alien-invoke remove-dead-code*
|
||||
maybe-drop-dead-outputs ;
|
||||
|
||||
M: #alien-indirect remove-dead-code*
|
||||
maybe-drop-dead-outputs ;
|
||||
|
|
|
@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
|
|||
compiler.tree.combinators compiler.tree sequences math math.private
|
||||
kernel tools.test accessors slots.private quotations.private
|
||||
prettyprint classes.tuple.private classes classes.tuple
|
||||
compiler.tree.intrinsics namespaces compiler.tree.propagation.info
|
||||
compiler.intrinsics namespaces compiler.tree.propagation.info
|
||||
stack-checker.errors kernel.private ;
|
||||
|
||||
\ escape-analysis must-infer
|
||||
|
|
|
@ -4,8 +4,8 @@ USING: kernel accessors sequences classes.tuple
|
|||
classes.tuple.private arrays math math.private slots.private
|
||||
combinators deques search-deques namespaces fry classes
|
||||
classes.algebra stack-checker.state
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.escape-analysis.nodes
|
||||
compiler.tree.escape-analysis.allocations ;
|
||||
|
@ -23,9 +23,8 @@ DEFER: record-literal-allocation
|
|||
[ <slot-value> [ swap record-literal-allocation ] keep ] map ;
|
||||
|
||||
: object-slots ( object -- slots/f )
|
||||
#! Delegation
|
||||
{
|
||||
{ [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
|
||||
{ [ dup class immutable-tuple-class? ] [ tuple-slots ] }
|
||||
{ [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
@ -37,7 +36,6 @@ DEFER: record-literal-allocation
|
|||
if* ;
|
||||
|
||||
M: #push escape-analysis*
|
||||
#! Delegation.
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
|
||||
: record-unknown-allocation ( #call -- )
|
||||
|
@ -59,7 +57,7 @@ M: #push escape-analysis*
|
|||
[ second node-value-info literal>> ] 2bi
|
||||
dup fixnum? [
|
||||
{
|
||||
{ [ over tuple class<= ] [ 3 - ] }
|
||||
{ [ over tuple class<= ] [ 2 - ] }
|
||||
{ [ over complex class<= ] [ 1 - ] }
|
||||
[ drop f ]
|
||||
} cond nip
|
||||
|
|
|
@ -1,9 +1,32 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences
|
||||
compiler.tree compiler.tree.combinators ;
|
||||
USING: kernel arrays accessors sequences sequences.private words
|
||||
fry namespaces math math.order memoize classes.builtin
|
||||
classes.tuple.private slots.private combinators layouts
|
||||
byte-arrays alien.accessors
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.normalization
|
||||
compiler.tree.propagation
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.cleanup
|
||||
compiler.tree.def-use
|
||||
compiler.tree.dead-code
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.finalization
|
||||
|
||||
! This pass runs after propagation, so that it can expand
|
||||
! built-in type predicates and memory allocation; these cannot
|
||||
! be expanded before propagation since we need to see 'fixnum?'
|
||||
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
|
||||
! We also delete empty stack shuffles and copies to facilitate
|
||||
! tail call optimization in the code generator. After this pass
|
||||
! runs, stack flow information is no longer accurate, since we
|
||||
! punt in 'splice-quot' and don't update everything that we
|
||||
! should; this simplifies the code, improves performance, and we
|
||||
! don't need the stack flow information after this pass anyway.
|
||||
|
||||
GENERIC: finalize* ( node -- nodes )
|
||||
|
||||
M: #copy finalize* drop f ;
|
||||
|
@ -13,6 +36,92 @@ M: #shuffle finalize*
|
|||
[ in>> ] [ out>> ] bi sequence=
|
||||
[ drop f ] when ;
|
||||
|
||||
: splice-quot ( quot -- nodes )
|
||||
[
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
but-last
|
||||
] with-scope ;
|
||||
|
||||
: builtin-predicate? ( #call -- ? )
|
||||
word>> "predicating" word-prop builtin-class? ;
|
||||
|
||||
MEMO: builtin-predicate-expansion ( word -- nodes )
|
||||
def>> splice-quot ;
|
||||
|
||||
: expand-builtin-predicate ( #call -- nodes )
|
||||
word>> builtin-predicate-expansion ;
|
||||
|
||||
: first-literal ( #call -- obj ) node-input-infos first literal>> ;
|
||||
|
||||
: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
|
||||
|
||||
: expand-tuple-boa? ( #call -- ? )
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
last-literal tuple-layout?
|
||||
] [ drop f ] if ;
|
||||
|
||||
MEMO: (tuple-boa-expansion) ( n -- quot )
|
||||
[
|
||||
[ 2 + ] map <reversed>
|
||||
[ '[ [ , set-slot ] keep ] % ] each
|
||||
] [ ] make ;
|
||||
|
||||
: tuple-boa-expansion ( layout -- quot )
|
||||
#! No memoization here since otherwise we'd hang on to
|
||||
#! tuple layout objects.
|
||||
size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
|
||||
|
||||
: expand-tuple-boa ( #call -- node )
|
||||
last-literal tuple-boa-expansion ;
|
||||
|
||||
MEMO: <array>-expansion ( n -- quot )
|
||||
[
|
||||
[ swap (array) ] %
|
||||
[ \ 2dup , , [ swap set-array-nth ] % ] each
|
||||
\ nip ,
|
||||
] [ ] make splice-quot ;
|
||||
|
||||
: expand-<array>? ( #call -- ? )
|
||||
dup word>> \ <array> eq? [
|
||||
first-literal dup integer?
|
||||
[ 0 32 between? ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: expand-<array> ( #call -- node )
|
||||
first-literal <array>-expansion ;
|
||||
|
||||
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||
|
||||
MEMO: <byte-array>-expansion ( n -- quot )
|
||||
[
|
||||
[ (byte-array) ] %
|
||||
bytes>cells [ cell * ] map
|
||||
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
|
||||
] [ ] make splice-quot ;
|
||||
|
||||
: expand-<byte-array>? ( #call -- ? )
|
||||
dup word>> \ <byte-array> eq? [
|
||||
first-literal dup integer?
|
||||
[ 0 128 between? ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: expand-<byte-array> ( #call -- nodes )
|
||||
first-literal <byte-array>-expansion ;
|
||||
|
||||
M: #call finalize*
|
||||
{
|
||||
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
|
||||
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
|
||||
{ [ dup expand-<array>? ] [ expand-<array> ] }
|
||||
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: node finalize* ;
|
||||
|
||||
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
|
||||
|
|
|
@ -151,7 +151,7 @@ M: #branch normalize*
|
|||
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
|
||||
[
|
||||
[ nip ] [
|
||||
dup [ +bottom+ eq? ] left-trim
|
||||
dup [ +bottom+ eq? ] trim-left
|
||||
[ [ length ] bi@ - tail* ] keep append
|
||||
] if
|
||||
] 3map ;
|
||||
|
|
|
@ -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
|
||||
|
@ -61,10 +59,34 @@ slots ;
|
|||
|
||||
: <value-info> ( -- info ) \ value-info new ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
all-slots
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
f prefix ;
|
||||
|
||||
DEFER: <literal-info>
|
||||
|
||||
: init-literal-info ( info -- info )
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] >>interval ] [
|
||||
[ [-inf,inf] >>interval ] dip
|
||||
{
|
||||
{ [ dup complex? ] [
|
||||
[ real-part <literal-info> ]
|
||||
[ imaginary-part <literal-info> ] bi
|
||||
2array >>slots
|
||||
] }
|
||||
{ [ dup tuple? ] [
|
||||
[ tuple-slots [ <literal-info> ] map ] [ class ] bi
|
||||
read-only-slots >>slots
|
||||
] }
|
||||
[ drop ]
|
||||
} cond
|
||||
] if ; inline
|
||||
|
||||
: init-value-info ( info -- info )
|
||||
dup literal?>> [
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
|
||||
init-literal-info
|
||||
] [
|
||||
dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
|
||||
null >>class
|
||||
|
@ -75,7 +97,7 @@ slots ;
|
|||
dup [ class>> ] [ interval>> ] bi interval>literal
|
||||
[ >>literal ] [ >>literal? ] bi*
|
||||
] if
|
||||
] if ;
|
||||
] if ; inline
|
||||
|
||||
: <class/interval-info> ( class interval -- info )
|
||||
<value-info>
|
||||
|
@ -84,7 +106,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 ;
|
||||
|
|
|
@ -7,6 +7,7 @@ classes.algebra combinators generic.math splitting fry locals
|
|||
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||
definitions
|
||||
stack-checker.state
|
||||
compiler.intrinsics
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
|
@ -17,11 +18,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 +67,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 +121,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 +159,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 +179,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 +197,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 +207,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
|
||||
2bi and maybe-or-never
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
|
@ -226,7 +227,7 @@ generic-comparison-ops [
|
|||
interval-intersect
|
||||
] 2bi
|
||||
<class/interval-info>
|
||||
] +outputs+ set-word-prop
|
||||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
{
|
||||
|
@ -250,36 +251,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> } [
|
||||
{ <tuple> <tuple-boa> (tuple) } [
|
||||
[
|
||||
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 +293,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 -- )
|
||||
|
|
|
@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ integer array } ] [
|
||||
[
|
||||
[ 2drop T{ mixed-mutable-immutable f 3 { } } ]
|
||||
[ { array } declare mixed-mutable-immutable boa ] if
|
||||
[ x>> ] [ y>> ] bi
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
! Recursive propagation
|
||||
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
|
||||
|
||||
|
@ -573,6 +581,18 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[
|
||||
[ { float float } declare <complex> ]
|
||||
[ 2drop C{ 0.0 0.0 } ]
|
||||
if real-part
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ POSTPONE: f } ] [
|
||||
[ { float } declare 0 eq? ] final-classes
|
||||
] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -31,26 +31,19 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
: tuple-constructor? ( word -- ? )
|
||||
{ <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
#! Delegation.
|
||||
all-slots rest-slice
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
{ f f } prepend ;
|
||||
|
||||
: fold-<tuple-boa> ( values class -- info )
|
||||
[ , f , [ literal>> ] map % ] { } make >tuple
|
||||
[ [ literal>> ] map ] dip prefix >tuple
|
||||
<literal-info> ;
|
||||
|
||||
: (propagate-tuple-constructor) ( values class -- info )
|
||||
[ [ value-info ] map ] dip [ read-only-slots ] keep
|
||||
over 2 tail-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ 2 tail-slice ] dip fold-<tuple-boa>
|
||||
over rest-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ rest-slice ] dip fold-<tuple-boa>
|
||||
] [
|
||||
<tuple-info>
|
||||
] if ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
#! Delegation
|
||||
in-d>> unclip-last
|
||||
value-info literal>> class>> (propagate-tuple-constructor) ;
|
||||
|
||||
|
@ -75,7 +68,6 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ 1 = ] [ length>> ] bi* and ;
|
||||
|
||||
: value-info-slot ( slot info -- info' )
|
||||
#! Delegation.
|
||||
{
|
||||
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
|
||||
{ [ 2dup length-accessor? ] [ nip length>> ] }
|
||||
|
|
|
@ -30,7 +30,7 @@ TUPLE: empty-tuple ;
|
|||
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
|
||||
[ 2 cons boa { [ ] [ ] } dispatch ]
|
||||
[ dup [ drop f ] [ "A" throw ] if ]
|
||||
[ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
|
||||
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
|
||||
[ [ ] [ ] curry curry call ]
|
||||
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
|
||||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||
|
|
|
@ -4,8 +4,8 @@ USING: namespaces assocs accessors kernel combinators
|
|||
classes.algebra sequences sequences.deep slots.private
|
||||
classes.tuple.private math math.private arrays
|
||||
stack-checker.branches
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.escape-analysis.simple
|
||||
|
|
|
@ -37,7 +37,7 @@ M: remote-process send ( message thread -- )
|
|||
send-remote-message ;
|
||||
|
||||
M: thread (serialize) ( obj -- )
|
||||
thread-id local-node get-global <remote-process>
|
||||
id>> local-node get-global <remote-process>
|
||||
(serialize) ;
|
||||
|
||||
: stop-node ( node -- )
|
||||
|
|
|
@ -18,13 +18,13 @@ IN: cpu.ppc.architecture
|
|||
: ds-reg 14 ; inline
|
||||
: rs-reg 15 ; inline
|
||||
|
||||
: reserved-area-size
|
||||
: reserved-area-size ( -- n )
|
||||
os {
|
||||
{ linux [ 2 ] }
|
||||
{ macosx [ 6 ] }
|
||||
} case cells ; foldable
|
||||
|
||||
: lr-save
|
||||
: lr-save ( -- n )
|
||||
os {
|
||||
{ linux [ 1 ] }
|
||||
{ macosx [ 2 ] }
|
||||
|
@ -32,12 +32,12 @@ IN: cpu.ppc.architecture
|
|||
|
||||
: param@ ( n -- x ) reserved-area-size + ; inline
|
||||
|
||||
: param-save-size 8 cells ; foldable
|
||||
: param-save-size ( -- n ) 8 cells ; foldable
|
||||
|
||||
: local@ ( n -- x )
|
||||
reserved-area-size param-save-size + + ; inline
|
||||
|
||||
: factor-area-size 2 cells ;
|
||||
: factor-area-size ( -- n ) 2 cells ; foldable
|
||||
|
||||
: next-save ( n -- i ) cell - ;
|
||||
|
||||
|
@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- )
|
|||
1 1 rot ADDI
|
||||
0 MTLR ;
|
||||
|
||||
: (%call) 11 MTLR BLRL ;
|
||||
: (%call) ( -- ) 11 MTLR BLRL ;
|
||||
|
||||
: (%jump) 11 MTCTR BCTR ;
|
||||
: (%jump) ( -- ) 11 MTCTR BCTR ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
@ -218,7 +218,7 @@ M: ppc %box-long-long ( n func -- )
|
|||
4 1 rot cell + local@ LWZ
|
||||
] when* r> f %alien-invoke ;
|
||||
|
||||
: temp@ stack-frame* factor-area-size - swap - ;
|
||||
: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
|
||||
|
||||
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.generator.fixup kernel namespaces sequences
|
||||
words math math.bitfields io.binary parser lexer ;
|
||||
words math math.bitwise io.binary parser lexer ;
|
||||
IN: cpu.ppc.assembler.backend
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
|
|
|
@ -4,24 +4,28 @@ USING: accessors alien alien.accessors alien.c-types arrays
|
|||
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 compiler.generator.fixup
|
||||
hashtables hashtables.private
|
||||
sequences.private sbufs vectors system layouts
|
||||
math.floats.private classes slots.private combinators
|
||||
compiler.constants ;
|
||||
math.floats.private classes slots.private
|
||||
combinators
|
||||
compiler.constants
|
||||
compiler.intrinsics
|
||||
compiler.generator
|
||||
compiler.generator.fixup
|
||||
compiler.generator.registers ;
|
||||
IN: cpu.ppc.intrinsics
|
||||
|
||||
: %slot-literal-known-tag
|
||||
: %slot-literal-known-tag ( -- out value offset )
|
||||
"val" operand
|
||||
"obj" operand
|
||||
"n" get cells
|
||||
"obj" get operand-tag - ;
|
||||
|
||||
: %slot-literal-any-tag
|
||||
: %slot-literal-any-tag ( -- out value offset )
|
||||
"obj" operand "scratch1" operand %untag
|
||||
"val" operand "scratch1" operand "n" get cells ;
|
||||
|
||||
: %slot-any
|
||||
: %slot-any ( -- out value offset )
|
||||
"obj" operand "scratch1" operand %untag
|
||||
"offset" operand "n" operand 1 SRAWI
|
||||
"scratch1" operand "val" operand "offset" operand ;
|
||||
|
@ -188,7 +192,7 @@ IN: cpu.ppc.intrinsics
|
|||
}
|
||||
} define-intrinsics
|
||||
|
||||
: generate-fixnum-mod
|
||||
: generate-fixnum-mod ( -- )
|
||||
#! PowerPC doesn't have a MOD instruction; so we compute
|
||||
#! x-(x/y)*y. Puts the result in "s" operand.
|
||||
"s" operand "r" operand "y" operand MULLW
|
||||
|
@ -259,7 +263,7 @@ IN: cpu.ppc.intrinsics
|
|||
\ fixnum+ \ ADD \ ADDO. overflow-template
|
||||
\ fixnum- \ SUBF \ SUBFO. overflow-template
|
||||
|
||||
: generate-fixnum/i
|
||||
: generate-fixnum/i ( -- )
|
||||
#! This VOP is funny. If there is an overflow, it falls
|
||||
#! through to the end, and the result is in "x" operand.
|
||||
#! Otherwise it jumps to the "no-overflow" label and the
|
||||
|
@ -437,44 +441,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
|
||||
|
@ -514,8 +518,8 @@ IN: cpu.ppc.intrinsics
|
|||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand dup %untag-fixnum
|
||||
"offset" operand dup "alien" operand ADD
|
||||
"value" operand "offset" operand 0 roll call ; inline
|
||||
"scratch" operand "offset" operand "alien" operand ADD
|
||||
"value" operand "scratch" operand 0 roll call ; inline
|
||||
|
||||
: alien-integer-get-template
|
||||
H{
|
||||
|
@ -523,7 +527,7 @@ IN: cpu.ppc.intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "value" } } }
|
||||
{ +scratch+ { { f "value" } { f "scratch" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} ;
|
||||
|
@ -539,6 +543,7 @@ IN: cpu.ppc.intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "scratch" } } }
|
||||
{ +clobber+ { "value" "offset" } }
|
||||
} ;
|
||||
|
||||
|
@ -579,7 +584,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { unboxed-alien "value" } } }
|
||||
{ +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} define-intrinsic
|
||||
|
@ -592,6 +597,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "scratch" } } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} define-intrinsic
|
||||
|
||||
|
@ -601,7 +607,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { float "value" } } }
|
||||
{ +scratch+ { { float "value" } { f "scratch" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} ;
|
||||
|
@ -613,6 +619,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "scratch" } } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} ;
|
||||
|
||||
|
|
|
@ -178,7 +178,7 @@ stack-params "__stack_value" c-type (>>reg-class) >>
|
|||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ class>> ] [ offset>> ] bi 2array
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
|
|
|
@ -4,10 +4,14 @@ USING: accessors alien alien.accessors arrays cpu.x86.assembler
|
|||
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
|
||||
kernel.private math math.private namespaces quotations sequences
|
||||
words generic byte-arrays hashtables hashtables.private
|
||||
compiler.generator compiler.generator.registers
|
||||
compiler.generator.fixup sequences.private sbufs sbufs.private
|
||||
sequences.private sbufs sbufs.private
|
||||
vectors vectors.private layouts system strings.private
|
||||
slots.private compiler.constants ;
|
||||
slots.private
|
||||
compiler.constants
|
||||
compiler.intrinsics
|
||||
compiler.generator
|
||||
compiler.generator.fixup
|
||||
compiler.generator.registers ;
|
||||
IN: cpu.x86.intrinsics
|
||||
|
||||
! Type checks
|
||||
|
@ -289,45 +293,45 @@ IN: cpu.x86.intrinsics
|
|||
{ +clobber+ { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
! \ (tuple) [
|
||||
! tuple "layout" get size>> 2 + cells [
|
||||
! ! Store layout
|
||||
! "layout" get "scratch" get load-literal
|
||||
! 1 object@ "scratch" operand MOV
|
||||
! ! Store tagged ptr in reg
|
||||
! "tuple" get tuple %store-tagged
|
||||
! ] %allot
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "layout" } } }
|
||||
! { +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
! { +output+ { "tuple" } }
|
||||
! } define-intrinsic
|
||||
!
|
||||
! \ (array) [
|
||||
! array "n" get 2 + cells [
|
||||
! ! Store length
|
||||
! 1 object@ "n" operand MOV
|
||||
! ! Store tagged ptr in reg
|
||||
! "array" get object %store-tagged
|
||||
! ] %allot
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "n" } } }
|
||||
! { +scratch+ { { f "array" } } }
|
||||
! { +output+ { "array" } }
|
||||
! } define-intrinsic
|
||||
!
|
||||
! \ (byte-array) [
|
||||
! byte-array "n" get 2 cells + [
|
||||
! ! Store length
|
||||
! 1 object@ "n" operand MOV
|
||||
! ! Store tagged ptr in reg
|
||||
! "array" get object %store-tagged
|
||||
! ] %allot
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "n" } } }
|
||||
! { +scratch+ { { f "array" } } }
|
||||
! { +output+ { "array" } }
|
||||
! } define-intrinsic
|
||||
\ (tuple) [
|
||||
tuple "layout" get size>> 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" get load-literal
|
||||
1 object@ "scratch" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (array) [
|
||||
array "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <ratio> [
|
||||
ratio 3 cells [
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
IN: db.tests
|
||||
USING: tools.test db kernel ;
|
||||
IN: db.tests
|
||||
|
||||
{ 1 0 } [ [ drop ] query-each ] must-infer-as
|
||||
{ 1 1 } [ [ ] query-map ] must-infer-as
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations destructors kernel math
|
||||
namespaces sequences sequences.lib classes.tuple words strings
|
||||
tools.walker accessors combinators.lib ;
|
||||
namespaces sequences classes.tuple words strings
|
||||
tools.walker accessors combinators ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db
|
||||
|
@ -15,24 +15,25 @@ TUPLE: db
|
|||
new
|
||||
H{ } clone >>insert-statements
|
||||
H{ } clone >>update-statements
|
||||
H{ } clone >>delete-statements ;
|
||||
H{ } clone >>delete-statements ; inline
|
||||
|
||||
GENERIC: make-db* ( seq class -- db )
|
||||
GENERIC: make-db* ( seq db -- db )
|
||||
|
||||
: make-db ( seq class -- db )
|
||||
new-db make-db* ;
|
||||
: make-db ( seq class -- db ) new-db make-db* ;
|
||||
|
||||
GENERIC: db-open ( db -- db )
|
||||
HOOK: db-close db ( handle -- )
|
||||
|
||||
: dispose-statements ( assoc -- ) values dispose-each ;
|
||||
|
||||
: dispose-db ( db -- )
|
||||
: db-dispose ( db -- )
|
||||
dup db [
|
||||
dup insert-statements>> dispose-statements
|
||||
dup update-statements>> dispose-statements
|
||||
dup delete-statements>> dispose-statements
|
||||
handle>> db-close
|
||||
{
|
||||
[ insert-statements>> dispose-statements ]
|
||||
[ update-statements>> dispose-statements ]
|
||||
[ delete-statements>> dispose-statements ]
|
||||
[ handle>> db-close ]
|
||||
} cleave
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
|
||||
|
@ -47,8 +48,8 @@ TUPLE: result-set sql in-params out-params handle n max ;
|
|||
swap >>in-params
|
||||
swap >>sql ;
|
||||
|
||||
HOOK: <simple-statement> db ( str in out -- statement )
|
||||
HOOK: <prepared-statement> db ( str in out -- statement )
|
||||
HOOK: <simple-statement> db ( string in out -- statement )
|
||||
HOOK: <prepared-statement> db ( string in out -- statement )
|
||||
GENERIC: prepare-statement ( statement -- )
|
||||
GENERIC: bind-statement* ( statement -- )
|
||||
GENERIC: low-level-bind ( statement -- )
|
|
@ -6,6 +6,5 @@ IN: db.errors
|
|||
ERROR: db-error ;
|
||||
ERROR: sql-error ;
|
||||
|
||||
|
||||
ERROR: table-exists ;
|
||||
ERROR: bad-schema ;
|
|
@ -13,7 +13,7 @@ USE: db.sqlite
|
|||
|
||||
[ "pool-test.db" temp-file delete-file ] ignore-errors
|
||||
|
||||
[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
|
||||
[ ] [ "pool-test.db" temp-file sqlite-db <db-pool> "pool" set ] unit-test
|
||||
|
||||
[ ] [ "pool" get expired>> t >>expired drop ] unit-test
|
||||
|
|
@ -4,8 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io
|
|||
kernel math math.parser namespaces prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators sequences.lib classes locals words tools.walker
|
||||
namespaces.lib accessors random db.queries destructors ;
|
||||
combinators classes locals words tools.walker
|
||||
nmake accessors random db.queries destructors ;
|
||||
USE: tools.walker
|
||||
IN: db.postgresql
|
||||
|
||||
|
@ -16,7 +16,7 @@ TUPLE: postgresql-statement < statement ;
|
|||
|
||||
TUPLE: postgresql-result-set < result-set ;
|
||||
|
||||
M: postgresql-db make-db* ( seq tuple -- db )
|
||||
M: postgresql-db make-db* ( seq db -- db )
|
||||
>r first4 r>
|
||||
swap >>db
|
||||
swap >>pass
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math namespaces sequences random
|
||||
strings math.parser math.intervals combinators
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types
|
||||
sequences.lib db.sql classes words shuffle arrays ;
|
||||
USING: accessors kernel math namespaces sequences random strings
|
||||
math.parser math.intervals combinators math.bitwise nmake db
|
||||
db.tuples db.types db.sql classes words shuffle arrays ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
@ -43,13 +42,6 @@ M: random-id-generator eval-generator ( singleton -- obj )
|
|||
: interval-comparison ( ? str -- str )
|
||||
"from" = " >" " <" ? swap [ "= " append ] when ;
|
||||
|
||||
: fp-infinity? ( float -- ? )
|
||||
dup float? [
|
||||
double>bits -52 shift 11 2^ 1- [ bitand ] keep =
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: (infinite-interval?) ( interval -- ?1 ?2 )
|
||||
[ from>> ] [ to>> ] bi
|
||||
[ first fp-infinity? ] bi@ ;
|
||||
|
@ -149,8 +141,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
: make-query ( tuple query -- tuple' )
|
||||
dupd
|
||||
{
|
||||
[ group>> [ do-group ] [ drop ] if-seq ]
|
||||
[ order>> [ do-order ] [ drop ] if-seq ]
|
||||
[ group>> [ drop ] [ do-group ] if-empty ]
|
||||
[ order>> [ drop ] [ do-order ] if-empty ]
|
||||
[ limit>> [ do-limit ] [ drop ] if* ]
|
||||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel parser quotations classes.tuple words math.order
|
||||
namespaces.lib namespaces sequences arrays combinators
|
||||
prettyprint strings math.parser sequences.lib math symbols ;
|
||||
nmake namespaces sequences arrays combinators
|
||||
prettyprint strings math.parser math symbols ;
|
||||
IN: db.sql
|
||||
|
||||
SYMBOLS: insert update delete select distinct columns from as
|
|
@ -118,6 +118,7 @@ FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int
|
|||
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
|
||||
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
|
||||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
|
||||
"int" "sqlite" "sqlite3_bind_int64"
|
||||
{ "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
|
||||
|
@ -131,6 +132,7 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
|
|||
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
|
||||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-column-uint64 ( pStmt col -- uint64 )
|
||||
"sqlite3_uint64" "sqlite" "sqlite3_column_int64"
|
||||
{ "sqlite3_stmt*" "int" } alien-invoke ;
|
|
@ -57,8 +57,7 @@ IN: db.sqlite.tests
|
|||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
[ ] [
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db
|
||||
hashtables io.files kernel math math.parser namespaces
|
||||
prettyprint sequences strings classes.tuple alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||
words combinators.lib db.types combinators math.intervals
|
||||
io namespaces.lib accessors vectors math.ranges random
|
||||
math.bitfields.lib db.queries destructors ;
|
||||
USE: tools.walker
|
||||
USING: alien arrays assocs classes compiler db hashtables
|
||||
io.files kernel math math.parser namespaces prettyprint
|
||||
sequences strings classes.tuple alien.c-types continuations
|
||||
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
|
||||
math.intervals io nmake accessors vectors math.ranges random
|
||||
math.bitwise db.queries destructors ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db < db path ;
|
||||
|
@ -19,7 +17,7 @@ M: sqlite-db db-open ( db -- db )
|
|||
dup path>> sqlite-open >>handle ;
|
||||
|
||||
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||
M: sqlite-db dispose ( db -- ) db-dispose ;
|
||||
|
||||
TUPLE: sqlite-statement < statement ;
|
||||
|
||||
|
@ -52,12 +50,12 @@ M: sqlite-result-set dispose ( result-set -- )
|
|||
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
|
||||
|
||||
M: sqlite-statement low-level-bind ( statement -- )
|
||||
[ statement-bind-params ] [ statement-handle ] bi
|
||||
[ bind-params>> ] [ handle>> ] bi
|
||||
[ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
|
||||
|
||||
M: sqlite-statement bind-statement* ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
dup statement-bound? [ dup reset-bindings ] when
|
||||
dup bound?>> [ dup reset-bindings ] when
|
||||
low-level-bind ;
|
||||
|
||||
GENERIC: sqlite-bind-conversion ( tuple obj -- array )
|
|
@ -3,8 +3,8 @@
|
|||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitfields.lib
|
||||
math.ranges strings sequences.lib urls fry ;
|
||||
db.postgresql accessors random math.bitwise
|
||||
math.ranges strings urls fry ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
@ -41,9 +41,9 @@ SYMBOL: person4
|
|||
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
|
||||
[ 1 ] [ person1 get person-the-id ] unit-test
|
||||
[ 1 ] [ person1 get the-id>> ] unit-test
|
||||
|
||||
[ ] [ 200 person1 get set-person-the-number ] unit-test
|
||||
[ ] [ person1 get 200 >>the-number drop ] unit-test
|
||||
|
||||
[ ] [ person1 get update-tuple ] unit-test
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays assocs classes db kernel namespaces
|
||||
classes.tuple words sequences slots math accessors
|
||||
math.parser io prettyprint db.types continuations
|
||||
destructors mirrors sequences.lib combinators.lib ;
|
||||
destructors mirrors ;
|
||||
IN: db.tuples
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
|
@ -71,13 +71,14 @@ SINGLETON: retryable
|
|||
] 2map >>bind-params ;
|
||||
|
||||
M: retryable execute-statement* ( statement type -- )
|
||||
drop [
|
||||
drop [ retries>> ] [
|
||||
[
|
||||
nip
|
||||
[ query-results dispose t ]
|
||||
[ ]
|
||||
[ regenerate-params bind-statement* f ] cleanup
|
||||
] curry
|
||||
] [ retries>> ] bi retry drop ;
|
||||
] bi attempt-all drop ;
|
||||
|
||||
: resulting-tuple ( class row out-params -- tuple )
|
||||
rot class new [
|
||||
|
@ -159,7 +160,8 @@ M: retryable execute-statement* ( statement type -- )
|
|||
dup dup class <select-by-slots-statement> do-select ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f )
|
||||
dup dup class \ query new 1 >>limit <query> do-select ?first ;
|
||||
dup dup class \ query new 1 >>limit <query> do-select
|
||||
[ f ] [ first ] if-empty ;
|
||||
|
||||
: do-count ( exemplar-tuple statement -- tuples )
|
||||
[
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs db kernel math math.parser
|
||||
sequences continuations sequences.deep sequences.lib
|
||||
sequences continuations sequences.deep
|
||||
words namespaces slots slots.private classes mirrors
|
||||
classes.tuple combinators calendar.format symbols
|
||||
classes.singleton accessors quotations random ;
|
||||
IN: db.types
|
||||
|
||||
HOOK: persistent-table db ( -- hash )
|
||||
HOOK: compound db ( str obj -- hash )
|
||||
HOOK: compound db ( string obj -- hash )
|
||||
|
||||
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
|
||||
|
||||
|
@ -78,7 +78,7 @@ FACTOR-BLOB NULL URL ;
|
|||
swap >>class
|
||||
dup normalize-spec ;
|
||||
|
||||
: number>string* ( n/str -- str )
|
||||
: number>string* ( n/string -- string )
|
||||
dup number? [ number>string ] when ;
|
||||
|
||||
: remove-db-assigned-id ( specs -- obj )
|
||||
|
@ -97,7 +97,7 @@ FACTOR-BLOB NULL URL ;
|
|||
|
||||
ERROR: unknown-modifier ;
|
||||
|
||||
: lookup-modifier ( obj -- str )
|
||||
: lookup-modifier ( obj -- string )
|
||||
{
|
||||
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
|
||||
[ persistent-table at* [ unknown-modifier ] unless third ]
|
||||
|
@ -105,43 +105,43 @@ ERROR: unknown-modifier ;
|
|||
|
||||
ERROR: no-sql-type ;
|
||||
|
||||
: (lookup-type) ( obj -- str )
|
||||
: (lookup-type) ( obj -- string )
|
||||
persistent-table at* [ no-sql-type ] unless ;
|
||||
|
||||
: lookup-type ( obj -- str )
|
||||
: lookup-type ( obj -- string )
|
||||
dup array? [
|
||||
unclip (lookup-type) first nip
|
||||
] [
|
||||
(lookup-type) first
|
||||
] if ;
|
||||
|
||||
: lookup-create-type ( obj -- str )
|
||||
: lookup-create-type ( obj -- string )
|
||||
dup array? [
|
||||
unclip (lookup-type) second swap compound
|
||||
] [
|
||||
(lookup-type) second
|
||||
] if ;
|
||||
|
||||
: single-quote ( str -- newstr )
|
||||
: single-quote ( string -- new-string )
|
||||
"'" swap "'" 3append ;
|
||||
|
||||
: double-quote ( str -- newstr )
|
||||
: double-quote ( string -- new-string )
|
||||
"\"" swap "\"" 3append ;
|
||||
|
||||
: paren ( str -- newstr )
|
||||
: paren ( string -- new-string )
|
||||
"(" swap ")" 3append ;
|
||||
|
||||
: join-space ( str1 str2 -- newstr )
|
||||
: join-space ( string1 string2 -- new-string )
|
||||
" " swap 3append ;
|
||||
|
||||
: modifiers ( spec -- str )
|
||||
: modifiers ( spec -- string )
|
||||
modifiers>> [ lookup-modifier ] map " " join
|
||||
dup empty? [ " " prepend ] unless ;
|
||||
|
||||
HOOK: bind% db ( spec -- )
|
||||
HOOK: bind# db ( spec obj -- )
|
||||
|
||||
: offset-of-slot ( str obj -- n )
|
||||
: offset-of-slot ( string obj -- n )
|
||||
class superclasses [ "slots" word-prop ] map concat
|
||||
slot-named offset>> ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
USING: alien arrays generic generic.math help.markup help.syntax
|
||||
kernel math memory strings sbufs vectors io io.files classes
|
||||
help generic.standard continuations system debugger.private
|
||||
io.files.private listener ;
|
||||
help generic.standard continuations system io.files.private
|
||||
listener ;
|
||||
IN: debugger
|
||||
|
||||
ARTICLE: "debugger" "The debugger"
|
||||
|
@ -22,8 +22,6 @@ ARTICLE: "debugger" "The debugger"
|
|||
{ $subsection :2 }
|
||||
{ $subsection :3 }
|
||||
{ $subsection :res }
|
||||
"Assertions:"
|
||||
{ $subsection "errors-assert" }
|
||||
"You can read more about error handling in " { $link "errors" } "." ;
|
||||
|
||||
ABOUT: "debugger"
|
||||
|
|
|
@ -10,14 +10,17 @@ IN: debugger.threads
|
|||
dup id>> #
|
||||
" (" % dup name>> %
|
||||
", " % dup quot>> unparse-short % ")" %
|
||||
] "" make swap write-object ":" print nl ;
|
||||
] "" make swap write-object ":" print ;
|
||||
|
||||
M: thread error-in-thread ( error thread -- )
|
||||
initial-thread get-global eq? [
|
||||
die drop
|
||||
] [
|
||||
global [
|
||||
error-thread get-global error-in-thread. print-error flush
|
||||
error-thread get-global error-in-thread. nl
|
||||
print-error nl
|
||||
:c
|
||||
flush
|
||||
] bind
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -15,7 +15,7 @@ GENERIC# whoa 1 ( s t -- w )
|
|||
PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
|
||||
|
||||
: hello-test ( hello/goodbye -- array )
|
||||
[ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
|
||||
[ hello? ] [ this>> ] [ that>> ] tri 3array ;
|
||||
|
||||
CONSULT: baz goodbye these>> ;
|
||||
M: hello foo this>> ;
|
||||
|
@ -34,8 +34,8 @@ M: hello bing hello-test ;
|
|||
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
|
||||
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
|
||||
|
||||
[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
|
||||
[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
|
||||
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
|
||||
[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
|
||||
[ H{ } ] [ bee protocol-consult ] unit-test
|
||||
|
||||
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
|
||||
|
|
|
@ -1,4 +0,0 @@
|
|||
USING: io.backend ;
|
||||
IN: editors.gvim.backend
|
||||
|
||||
HOOK: gvim-path io-backend ( -- path )
|
|
@ -1 +0,0 @@
|
|||
unportable
|
|
@ -1,10 +1,12 @@
|
|||
USING: io.backend io.files kernel math math.parser
|
||||
namespaces sequences system combinators
|
||||
editors.vim editors.gvim.backend vocabs.loader ;
|
||||
editors.vim vocabs.loader ;
|
||||
IN: editors.gvim
|
||||
|
||||
SINGLETON: gvim
|
||||
|
||||
HOOK: gvim-path io-backend ( -- path )
|
||||
|
||||
M: gvim vim-command ( file line -- string )
|
||||
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: io.unix.backend kernel namespaces editors.gvim.backend
|
||||
USING: io.unix.backend kernel namespaces editors.gvim
|
||||
system ;
|
||||
IN: editors.gvim.unix
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: editors.gvim.backend io.files io.windows kernel namespaces
|
||||
USING: editors.gvim io.files io.windows kernel namespaces
|
||||
sequences windows.shell32 io.paths system ;
|
||||
IN: editors.gvim.windows
|
||||
|
||||
|
|
|
@ -88,6 +88,8 @@ IN: farkup.tests
|
|||
|
||||
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
||||
|
||||
[ "<pre>hello\n</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
|
@ -61,8 +61,8 @@ INSTANCE: float-array sequence
|
|||
: F{ \ } [ >float-array ] parse-literal ; parsing
|
||||
|
||||
M: float-array pprint-delims drop \ F{ \ } ;
|
||||
|
||||
M: float-array >pprint-sequence ;
|
||||
M: float-array pprint* pprint-object ;
|
||||
|
||||
USING: hints math.vectors arrays ;
|
||||
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue