Merge branch 'master' of git://factorcode.org/git/factor
commit
1e69e739bf
|
@ -1,11 +1,15 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays calendar combinators generic init kernel math
|
||||
namespaces sequences heaps boxes threads debugger quotations
|
||||
assocs math.order ;
|
||||
USING: accessors arrays calendar combinators generic init
|
||||
kernel math namespaces sequences heaps boxes threads debugger
|
||||
quotations assocs math.order ;
|
||||
IN: alarms
|
||||
|
||||
TUPLE: alarm quot time interval entry ;
|
||||
TUPLE: alarm
|
||||
{ quot callable initial: [ ] }
|
||||
{ time timestamp }
|
||||
interval
|
||||
{ entry box } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -15,31 +19,28 @@ SYMBOL: alarm-thread
|
|||
: notify-alarm-thread ( -- )
|
||||
alarm-thread get-global interrupt ;
|
||||
|
||||
: check-alarm
|
||||
dup duration? over not or [ "Not a duration" throw ] unless
|
||||
over timestamp? [ "Not a timestamp" throw ] unless
|
||||
pick callable? [ "Not a quotation" throw ] unless ; inline
|
||||
ERROR: bad-alarm-frequency frequency ;
|
||||
: check-alarm ( frequency/f -- frequency/f )
|
||||
dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
|
||||
|
||||
: <alarm> ( quot time frequency -- alarm )
|
||||
check-alarm <box> alarm boa ;
|
||||
|
||||
: register-alarm ( alarm -- )
|
||||
dup dup alarm-time alarms get-global heap-push*
|
||||
swap alarm-entry >box
|
||||
dup dup time>> alarms get-global heap-push*
|
||||
swap entry>> >box
|
||||
notify-alarm-thread ;
|
||||
|
||||
: alarm-expired? ( alarm now -- ? )
|
||||
>r alarm-time r> before=? ;
|
||||
[ time>> ] dip before=? ;
|
||||
|
||||
: reschedule-alarm ( alarm -- )
|
||||
dup alarm-time over alarm-interval time+
|
||||
over set-alarm-time
|
||||
register-alarm ;
|
||||
dup [ swap interval>> time+ ] change-time register-alarm ;
|
||||
|
||||
: call-alarm ( alarm -- )
|
||||
dup alarm-entry box> drop
|
||||
dup alarm-quot "Alarm execution" spawn drop
|
||||
dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
|
||||
[ entry>> box> drop ]
|
||||
[ quot>> "Alarm execution" spawn drop ]
|
||||
[ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
|
||||
|
||||
: (trigger-alarms) ( alarms now -- )
|
||||
over heap-empty? [
|
||||
|
@ -57,7 +58,7 @@ SYMBOL: alarm-thread
|
|||
|
||||
: next-alarm ( alarms -- timestamp/f )
|
||||
dup heap-empty?
|
||||
[ drop f ] [ heap-peek drop alarm-time ] if ;
|
||||
[ drop f ] [ heap-peek drop time>> ] if ;
|
||||
|
||||
: alarm-thread-loop ( -- )
|
||||
alarms get-global
|
||||
|
@ -66,7 +67,7 @@ SYMBOL: alarm-thread
|
|||
|
||||
: cancel-alarms ( alarms -- )
|
||||
[
|
||||
heap-pop-all [ nip alarm-entry box> drop ] assoc-each
|
||||
heap-pop-all [ nip entry>> box> drop ] assoc-each
|
||||
] when* ;
|
||||
|
||||
: init-alarms ( -- )
|
||||
|
@ -88,4 +89,4 @@ PRIVATE>
|
|||
[ hence ] keep add-alarm ;
|
||||
|
||||
: cancel-alarm ( alarm -- )
|
||||
alarm-entry [ alarms get-global heap-delete ] if-box? ;
|
||||
entry>> [ alarms get-global heap-delete ] if-box? ;
|
||||
|
|
|
@ -0,0 +1,15 @@
|
|||
USING: kernel words help.markup help.syntax ;
|
||||
IN: alias
|
||||
|
||||
HELP: ALIAS:
|
||||
{ $syntax "ALIAS: new-word existing-word" }
|
||||
{ $values { "new-word" word } { "existing-word" word } }
|
||||
{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
|
||||
{ $examples
|
||||
{ $example "ALIAS: sequence-nth nth"
|
||||
"0 { 10 20 30 } sequence-nth"
|
||||
"10"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.order sequences ;
|
||||
USING: kernel math math.order sequences
|
||||
combinators.short-circuit ;
|
||||
IN: ascii
|
||||
|
||||
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
|
||||
|
@ -20,7 +21,7 @@ IN: ascii
|
|||
dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
|
||||
|
||||
: Letter? ( ch -- ? )
|
||||
dup letter? [ drop t ] [ LETTER? ] if ; inline
|
||||
[ [ letter? ] [ LETTER? ] ] 1|| ;
|
||||
|
||||
: alpha? ( ch -- ? )
|
||||
dup Letter? [ drop t ] [ digit? ] if ; inline
|
||||
[ [ Letter? ] [ digit? ] ] 1|| ;
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: kernel tools.test base64 strings ;
|
||||
IN: base64.tests
|
||||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
|
||||
] unit-test
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences io.binary splitting grouping ;
|
||||
IN: base64
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs accessors ;
|
||||
USING: kernel assocs accessors summary ;
|
||||
IN: biassocs
|
||||
|
||||
TUPLE: biassoc from to ;
|
||||
|
@ -23,8 +23,13 @@ M: biassoc value-at* to>> at* ;
|
|||
M: biassoc set-at
|
||||
[ from>> set-at ] [ swapd to>> once-at ] 3bi ;
|
||||
|
||||
ERROR: no-biassoc-deletion ;
|
||||
|
||||
M: no-biassoc-deletion summary
|
||||
drop "biassocs do not support deletion" ;
|
||||
|
||||
M: biassoc delete-at
|
||||
"biassocs do not support deletion" throw ;
|
||||
no-biassoc-deletion ;
|
||||
|
||||
M: biassoc >alist
|
||||
from>> >alist ;
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
USING: vocabs.loader vocabs kernel ;
|
||||
IN: bootstrap.handbook
|
||||
|
||||
"bootstrap.help" vocab [ "help.handbook" require ] when
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
USING: vocabs.loader sequences system
|
||||
random random.mersenne-twister combinators init
|
||||
namespaces random ;
|
||||
IN: bootstrap.random
|
||||
|
||||
"random.mersenne-twister" require
|
||||
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: vocabs.loader sequences ;
|
||||
IN: bootstrap.tools
|
||||
|
||||
{
|
||||
"inspector"
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: alien namespaces system combinators kernel sequences
|
||||
vocabs vocabs.loader ;
|
||||
IN: bootstrap.ui
|
||||
|
||||
"bootstrap.compiler" vocab [
|
||||
"ui-backend" get [
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: strings.parser kernel namespaces unicode.data ;
|
||||
IN: bootstrap.unicode
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
name>char-hook set-global
|
||||
|
|
|
@ -0,0 +1,31 @@
|
|||
! 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 ;
|
||||
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." } ;
|
||||
|
||||
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 } "." } ;
|
||||
|
||||
{ timestamp duration } related-words
|
||||
|
||||
HELP: gmt-offset-duration
|
||||
{ $values { "duration" duration } }
|
||||
{ $description "Returns a " { $link duration } " object with the GMT offset returned by " { $link gmt-offset } "." } ;
|
||||
|
||||
HELP: <date>
|
||||
{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
|
||||
{ $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 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: month-names
|
||||
{ $values { "array" array } }
|
||||
{ $description "Returns an array with the English names of all the months. January has a index of 1 instead of 0." } ;
|
|
@ -1,52 +1,90 @@
|
|||
! 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 ;
|
||||
memoize summary combinators.short-circuit ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
||||
C: <timestamp> timestamp
|
||||
|
||||
TUPLE: duration year month day hour minute second ;
|
||||
TUPLE: duration
|
||||
{ year real }
|
||||
{ month real }
|
||||
{ day real }
|
||||
{ hour real }
|
||||
{ minute real }
|
||||
{ second real } ;
|
||||
|
||||
C: <duration> duration
|
||||
|
||||
TUPLE: timestamp
|
||||
{ year integer }
|
||||
{ month integer }
|
||||
{ day integer }
|
||||
{ hour integer }
|
||||
{ minute integer }
|
||||
{ second real }
|
||||
{ gmt-offset duration } ;
|
||||
|
||||
C: <timestamp> timestamp
|
||||
|
||||
: gmt-offset-duration ( -- duration )
|
||||
0 0 0 gmt-offset <duration> ;
|
||||
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset-duration <timestamp> ;
|
||||
|
||||
: month-names
|
||||
ERROR: not-a-month n ;
|
||||
M: not-a-month summary
|
||||
drop "Months are indexed starting at 1" ;
|
||||
|
||||
<PRIVATE
|
||||
: check-month ( n -- n )
|
||||
dup zero? [ not-a-month ] when ;
|
||||
PRIVATE>
|
||||
|
||||
: month-names ( -- array )
|
||||
{
|
||||
"Not a month" "January" "February" "March" "April" "May" "June"
|
||||
"January" "February" "March" "April" "May" "June"
|
||||
"July" "August" "September" "October" "November" "December"
|
||||
} ;
|
||||
|
||||
: month-abbreviations
|
||||
: month-name ( n -- string )
|
||||
check-month 1- month-names nth ;
|
||||
|
||||
: month-abbreviations ( -- array )
|
||||
{
|
||||
"Not a month"
|
||||
"Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
|
||||
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
|
||||
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
|
||||
} ;
|
||||
|
||||
: day-names
|
||||
: month-abbreviation ( n -- array )
|
||||
check-month 1- month-abbreviations nth ;
|
||||
|
||||
: day-names ( -- array )
|
||||
{
|
||||
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
|
||||
} ;
|
||||
|
||||
: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
|
||||
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
|
||||
: day-name ( n -- string ) day-names nth ;
|
||||
|
||||
: average-month 30+5/12 ; inline
|
||||
: months-per-year 12 ; inline
|
||||
: days-per-year 3652425/10000 ; inline
|
||||
: hours-per-year 876582/100 ; inline
|
||||
: minutes-per-year 5259492/10 ; inline
|
||||
: seconds-per-year 31556952 ; inline
|
||||
: day-abbreviations2 ( -- array )
|
||||
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
|
||||
|
||||
: day-abbreviation2 ( n -- string )
|
||||
day-abbreviations2 nth ;
|
||||
|
||||
: day-abbreviations3 ( -- array )
|
||||
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
|
||||
|
||||
: day-abbreviation3 ( n -- string )
|
||||
day-abbreviations3 nth ;
|
||||
|
||||
: average-month ( -- ratio ) 30+5/12 ; inline
|
||||
: months-per-year ( -- integer ) 12 ; inline
|
||||
: days-per-year ( -- ratio ) 3652425/10000 ; inline
|
||||
: hours-per-year ( -- ratio ) 876582/100 ; inline
|
||||
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
|
||||
: seconds-per-year ( -- integer ) 31556952 ; inline
|
||||
|
||||
:: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
|
@ -113,10 +151,12 @@ GENERIC: +second ( timestamp x -- timestamp )
|
|||
[ floor >integer ] keep over - ;
|
||||
|
||||
: adjust-leap-year ( timestamp -- timestamp )
|
||||
dup day>> 29 = over month>> 2 = pick leap-year? not and and
|
||||
dup
|
||||
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
|
||||
[ 3 >>month 1 >>day ] when ;
|
||||
|
||||
: unless-zero >r dup zero? [ drop ] r> if ; inline
|
||||
: unless-zero ( n quot -- )
|
||||
[ dup zero? [ drop ] ] dip if ; inline
|
||||
|
||||
M: integer +year ( timestamp n -- timestamp )
|
||||
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
|
||||
|
|
|
@ -26,11 +26,11 @@ IN: calendar.format
|
|||
|
||||
: DD ( time -- ) day>> write-00 ;
|
||||
|
||||
: DAY ( time -- ) day-of-week day-abbreviations3 nth write ;
|
||||
: DAY ( time -- ) day-of-week day-abbreviation3 write ;
|
||||
|
||||
: MM ( time -- ) month>> write-00 ;
|
||||
|
||||
: MONTH ( time -- ) month>> month-abbreviations nth write ;
|
||||
: MONTH ( time -- ) month>> month-abbreviation write ;
|
||||
|
||||
: YYYY ( time -- ) year>> write-0000 ;
|
||||
|
||||
|
@ -57,7 +57,7 @@ GENERIC: month. ( obj -- )
|
|||
|
||||
M: array month. ( pair -- )
|
||||
first2
|
||||
[ month-names nth write bl number>string print ]
|
||||
[ month-name write bl number>string print ]
|
||||
[ 1 zeller-congruence ]
|
||||
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
|
||||
over " " <repetition> concat write
|
||||
|
@ -191,7 +191,7 @@ ERROR: invalid-timestamp-format ;
|
|||
"," read-token day-abbreviations3 member? check-timestamp drop
|
||||
read1 CHAR: \s assert=
|
||||
read-sp checked-number >>day
|
||||
read-sp month-abbreviations index check-timestamp >>month
|
||||
read-sp month-abbreviations index 1+ check-timestamp >>month
|
||||
read-sp checked-number >>year
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
@ -206,7 +206,7 @@ ERROR: invalid-timestamp-format ;
|
|||
"," read-token day-abbreviations3 member? check-timestamp drop
|
||||
read1 CHAR: \s assert=
|
||||
"-" read-token checked-number >>day
|
||||
"-" read-token month-abbreviations index check-timestamp >>month
|
||||
"-" read-token month-abbreviations index 1+ check-timestamp >>month
|
||||
read-sp checked-number >>year
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
@ -219,7 +219,7 @@ ERROR: invalid-timestamp-format ;
|
|||
: (cookie-string>timestamp-2) ( -- timestamp )
|
||||
timestamp new
|
||||
read-sp day-abbreviations3 member? check-timestamp drop
|
||||
read-sp month-abbreviations index check-timestamp >>month
|
||||
read-sp month-abbreviations index 1+ check-timestamp >>month
|
||||
read-sp checked-number >>day
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings
|
||||
USING: accessors alien alien.c-types alien.strings
|
||||
arrays assocs combinators compiler kernel
|
||||
math namespaces parser prettyprint prettyprint.sections
|
||||
quotations sequences strings words cocoa.runtime io macros
|
||||
|
@ -46,11 +46,11 @@ TUPLE: selector name object ;
|
|||
MEMO: <selector> ( name -- sel ) f \ selector boa ;
|
||||
|
||||
: selector ( selector -- alien )
|
||||
dup selector-object expired? [
|
||||
dup selector-name sel_registerName
|
||||
dup rot set-selector-object
|
||||
dup object>> expired? [
|
||||
dup name>> sel_registerName
|
||||
[ >>object drop ] keep
|
||||
] [
|
||||
selector-object
|
||||
object>>
|
||||
] if ;
|
||||
|
||||
SYMBOL: objc-methods
|
||||
|
|
|
@ -15,7 +15,7 @@ TUPLE: frame-required n ;
|
|||
|
||||
: stack-frame-size ( code -- n )
|
||||
no-stack-frame [
|
||||
dup frame-required? [ frame-required-n max ] [ drop ] if
|
||||
dup frame-required? [ n>> max ] [ drop ] if
|
||||
] reduce ;
|
||||
|
||||
GENERIC: fixup* ( frame-size obj -- frame-size )
|
||||
|
@ -29,7 +29,7 @@ TUPLE: label offset ;
|
|||
: <label> ( -- label ) label new ;
|
||||
|
||||
M: label fixup*
|
||||
compiled-offset swap set-label-offset ;
|
||||
compiled-offset >>offset drop ;
|
||||
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
|
@ -138,7 +138,7 @@ SYMBOL: literal-table
|
|||
|
||||
: resolve-labels ( labels -- labels' )
|
||||
[
|
||||
first3 label-offset
|
||||
first3 offset>>
|
||||
[ "Unresolved label" throw ] unless*
|
||||
3array
|
||||
] map concat ;
|
||||
|
|
|
@ -102,12 +102,12 @@ TUPLE: cached loc vreg ;
|
|||
|
||||
C: <cached> cached
|
||||
|
||||
M: cached set-operand-class cached-vreg set-operand-class ;
|
||||
M: cached operand-class* cached-vreg operand-class* ;
|
||||
M: cached set-operand-class vreg>> set-operand-class ;
|
||||
M: cached operand-class* vreg>> operand-class* ;
|
||||
M: cached move-spec drop cached ;
|
||||
M: cached live-vregs* cached-vreg live-vregs* ;
|
||||
M: cached live-vregs* vreg>> live-vregs* ;
|
||||
M: cached live-loc? cached-loc live-loc? ;
|
||||
M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
|
||||
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
|
||||
M: cached lazy-store
|
||||
2dup cached-loc live-loc?
|
||||
[ "live-locs" get at %move ] [ 2drop ] if ;
|
||||
|
@ -169,7 +169,7 @@ INSTANCE: unboxed-c-ptr value
|
|||
! A constant value
|
||||
TUPLE: constant value ;
|
||||
C: <constant> constant
|
||||
M: constant operand-class* constant-value class ;
|
||||
M: constant operand-class* value>> class ;
|
||||
M: constant move-spec class ;
|
||||
|
||||
INSTANCE: constant value
|
||||
|
@ -204,7 +204,7 @@ INSTANCE: constant value
|
|||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||
|
||||
{ { f constant } [ constant-value swap load-literal ] }
|
||||
{ { f constant } [ value>> swap load-literal ] }
|
||||
|
||||
{ { f float } [ %box-float ] }
|
||||
{ { f unboxed-alien } [ %box-alien ] }
|
||||
|
@ -420,7 +420,7 @@ M: loc lazy-store
|
|||
#! with the area of the data stack above the stack pointer
|
||||
find-tmp-loc slow-shuffle-mapping [
|
||||
[
|
||||
swap dup cached? [ cached-vreg ] when %move
|
||||
swap dup cached? [ vreg>> ] when %move
|
||||
] assoc-each
|
||||
] keep >hashtable do-shuffle ;
|
||||
|
||||
|
@ -480,7 +480,7 @@ M: loc lazy-store
|
|||
: substitute-vreg? ( old new -- ? )
|
||||
#! We don't substitute locs for float or alien vregs,
|
||||
#! since in those cases the boxing overhead might kill us.
|
||||
cached-vreg tagged? >r loc? r> and ;
|
||||
vreg>> tagged? >r loc? r> and ;
|
||||
|
||||
: substitute-vregs ( values vregs -- )
|
||||
[ vreg-substitution ] 2map
|
||||
|
@ -488,7 +488,7 @@ M: loc lazy-store
|
|||
[ >r stack>> r> substitute-here ] curry each-phantom ;
|
||||
|
||||
: set-operand ( value var -- )
|
||||
>r dup constant? [ constant-value ] when r> set ;
|
||||
>r dup constant? [ value>> ] when r> set ;
|
||||
|
||||
: lazy-load ( values template -- )
|
||||
#! Set operand vars here.
|
||||
|
@ -506,7 +506,7 @@ M: loc lazy-store
|
|||
|
||||
: clash? ( seq -- ? )
|
||||
phantoms [ stack>> ] bi@ append [
|
||||
dup cached? [ cached-vreg ] when swap member?
|
||||
dup cached? [ vreg>> ] when swap member?
|
||||
] with contains? ;
|
||||
|
||||
: outputs-clash? ( -- ? )
|
||||
|
@ -516,7 +516,7 @@ M: loc lazy-store
|
|||
|
||||
: count-input-vregs ( phantom spec -- )
|
||||
phantom&spec [
|
||||
>r dup cached? [ cached-vreg ] when r> first allocation
|
||||
>r dup cached? [ vreg>> ] when r> first allocation
|
||||
] 2map count-vregs ;
|
||||
|
||||
: count-scratch-regs ( spec -- )
|
||||
|
@ -557,7 +557,7 @@ M: loc lazy-store
|
|||
#! the value is always good.
|
||||
dup quotation? [
|
||||
over constant?
|
||||
[ >r constant-value r> call ] [ 2drop f ] if
|
||||
[ >r value>> r> call ] [ 2drop f ] if
|
||||
] [
|
||||
2drop t
|
||||
] if ;
|
||||
|
@ -648,7 +648,7 @@ UNION: immediate fixnum POSTPONE: f ;
|
|||
phantom-datastack get stack>> push ;
|
||||
|
||||
: phantom-shuffle ( shuffle -- )
|
||||
[ effect-in length phantom-datastack get phantom-input ] keep
|
||||
[ in>> length phantom-datastack get phantom-input ] keep
|
||||
shuffle* phantom-datastack get phantom-append ;
|
||||
|
||||
: phantom->r ( n -- )
|
||||
|
|
|
@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
|
|||
namespaces namespaces tools.test sequences stack-checker
|
||||
stack-checker.errors words arrays parser quotations
|
||||
continuations effects namespaces.private io io.streams.string
|
||||
memory system threads tools.test math ;
|
||||
memory system threads tools.test math accessors ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ;
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
@ -288,7 +288,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
|
||||
: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
|
||||
|
||||
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
|
||||
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
|
||||
|
||||
[ t ] [ callback-1 alien? ] unit-test
|
||||
|
||||
|
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.promises concurrency.mailboxes kernel arrays
|
||||
continuations ;
|
||||
continuations accessors ;
|
||||
IN: concurrency.futures
|
||||
|
||||
: future ( quot -- future )
|
||||
<promise> [
|
||||
[ [ >r call r> fulfill ] 2curry "Future" ] keep
|
||||
promise-mailbox spawn-linked-to drop
|
||||
mailbox>> spawn-linked-to drop
|
||||
] keep ; inline
|
||||
|
||||
: ?future-timeout ( future timeout -- value )
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
! Concurrency library for Factor, based on Erlang/Termite style
|
||||
! concurrency.
|
||||
USING: kernel threads concurrency.mailboxes continuations
|
||||
namespaces assocs random ;
|
||||
namespaces assocs random accessors ;
|
||||
IN: concurrency.messaging
|
||||
|
||||
GENERIC: send ( message thread -- )
|
||||
|
@ -45,11 +45,11 @@ TUPLE: synchronous data sender tag ;
|
|||
TUPLE: reply data tag ;
|
||||
|
||||
: <reply> ( data synchronous -- reply )
|
||||
synchronous-tag \ reply boa ;
|
||||
tag>> \ reply boa ;
|
||||
|
||||
: synchronous-reply? ( response synchronous -- ? )
|
||||
over reply?
|
||||
[ >r reply-tag r> synchronous-tag = ]
|
||||
[ >r tag>> r> tag>> = ]
|
||||
[ 2drop f ] if ;
|
||||
|
||||
: send-synchronous ( message thread -- reply )
|
||||
|
@ -58,15 +58,15 @@ TUPLE: reply data tag ;
|
|||
] [
|
||||
>r <synchronous> dup r> send
|
||||
[ synchronous-reply? ] curry receive-if
|
||||
reply-data
|
||||
data>>
|
||||
] if ;
|
||||
|
||||
: reply-synchronous ( message synchronous -- )
|
||||
[ <reply> ] keep synchronous-sender send ;
|
||||
[ <reply> ] keep sender>> send ;
|
||||
|
||||
: handle-synchronous ( quot -- )
|
||||
receive [
|
||||
synchronous-data swap call
|
||||
data>> swap call
|
||||
] keep reply-synchronous ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.mailboxes kernel continuations ;
|
||||
USING: accessors concurrency.mailboxes kernel continuations ;
|
||||
IN: concurrency.promises
|
||||
|
||||
TUPLE: promise mailbox ;
|
||||
|
@ -9,17 +9,17 @@ TUPLE: promise mailbox ;
|
|||
<mailbox> promise boa ;
|
||||
|
||||
: promise-fulfilled? ( promise -- ? )
|
||||
promise-mailbox mailbox-empty? not ;
|
||||
mailbox>> mailbox-empty? not ;
|
||||
|
||||
: fulfill ( value promise -- )
|
||||
dup promise-fulfilled? [
|
||||
"Promise already fulfilled" throw
|
||||
] [
|
||||
promise-mailbox mailbox-put
|
||||
mailbox>> mailbox-put
|
||||
] if ;
|
||||
|
||||
: ?promise-timeout ( promise timeout -- result )
|
||||
>r promise-mailbox r> block-if-empty mailbox-peek ;
|
||||
>r mailbox>> r> block-if-empty mailbox-peek ;
|
||||
|
||||
: ?promise ( promise -- result )
|
||||
f ?promise-timeout ;
|
||||
|
|
|
@ -1,29 +1,34 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: dlists kernel threads math concurrency.conditions
|
||||
continuations ;
|
||||
continuations accessors summary ;
|
||||
IN: concurrency.semaphores
|
||||
|
||||
TUPLE: semaphore count threads ;
|
||||
|
||||
ERROR: negative-count-semaphore ;
|
||||
|
||||
M: negative-count-semaphore summary
|
||||
drop "Cannot have semaphore with negative count" ;
|
||||
|
||||
: <semaphore> ( n -- semaphore )
|
||||
dup 0 < [ "Cannot have semaphore with negative count" throw ] when
|
||||
dup 0 < [ negative-count-semaphore ] when
|
||||
<dlist> semaphore boa ;
|
||||
|
||||
: wait-to-acquire ( semaphore timeout -- )
|
||||
>r semaphore-threads r> "semaphore" wait ;
|
||||
[ threads>> ] dip "semaphore" wait ;
|
||||
|
||||
: acquire-timeout ( semaphore timeout -- )
|
||||
over semaphore-count zero?
|
||||
over count>> zero?
|
||||
[ dupd wait-to-acquire ] [ drop ] if
|
||||
dup semaphore-count 1- swap set-semaphore-count ;
|
||||
[ 1- ] change-count drop ;
|
||||
|
||||
: acquire ( semaphore -- )
|
||||
f acquire-timeout ;
|
||||
|
||||
: release ( semaphore -- )
|
||||
dup semaphore-count 1+ over set-semaphore-count
|
||||
semaphore-threads notify-1 ;
|
||||
[ 1+ ] change-count
|
||||
threads>> notify-1 ;
|
||||
|
||||
: with-semaphore-timeout ( semaphore timeout quot -- )
|
||||
pick rot acquire-timeout swap
|
||||
|
|
|
@ -23,16 +23,16 @@ M: tuple error-help class ;
|
|||
M: string error. print ;
|
||||
|
||||
: :s ( -- )
|
||||
error-continuation get continuation-data stack. ;
|
||||
error-continuation get data>> stack. ;
|
||||
|
||||
: :r ( -- )
|
||||
error-continuation get continuation-retain stack. ;
|
||||
error-continuation get retain>> stack. ;
|
||||
|
||||
: :c ( -- )
|
||||
error-continuation get continuation-call callstack. ;
|
||||
error-continuation get call>> callstack. ;
|
||||
|
||||
: :get ( variable -- value )
|
||||
error-continuation get continuation-name assoc-stack ;
|
||||
error-continuation get name>> assoc-stack ;
|
||||
|
||||
: :res ( n -- * )
|
||||
1- restarts get-global nth f restarts set-global restart ;
|
||||
|
|
|
@ -26,7 +26,7 @@ TUPLE: document < model locs ;
|
|||
: remove-loc ( loc document -- ) locs>> delete ;
|
||||
|
||||
: update-locs ( loc document -- )
|
||||
document-locs [ set-model ] with each ;
|
||||
locs>> [ set-model ] with each ;
|
||||
|
||||
: doc-line ( n document -- string ) model-value nth ;
|
||||
|
||||
|
@ -132,7 +132,7 @@ TUPLE: document < model locs ;
|
|||
|
||||
: set-doc-string ( string document -- )
|
||||
>r string-lines V{ } like r> [ set-model ] keep
|
||||
dup doc-end swap update-locs ;
|
||||
[ doc-end ] [ update-locs ] bi ;
|
||||
|
||||
: clear-doc ( document -- )
|
||||
"" swap set-doc-string ;
|
||||
|
|
|
@ -58,7 +58,7 @@ IN: heaps.tests
|
|||
dup length random dup pick nth >r swap delete-nth r> ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
[ [ entry-key ] compare ] sort ;
|
||||
[ [ key>> ] compare ] sort ;
|
||||
|
||||
: delete-test ( n -- ? )
|
||||
[
|
||||
|
@ -67,7 +67,7 @@ IN: heaps.tests
|
|||
dup data>> clone swap
|
||||
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
|
||||
data>>
|
||||
[ [ entry-key ] map ] bi@
|
||||
[ [ key>> ] map ] bi@
|
||||
[ natural-sort ] bi@ ;
|
||||
|
||||
11 [
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences arrays assocs sequences.private
|
||||
growable accessors math.order ;
|
||||
growable accessors math.order summary ;
|
||||
IN: heaps
|
||||
|
||||
GENERIC: heap-push* ( value key heap -- entry )
|
||||
|
@ -61,7 +61,7 @@ M: heap heap-size ( heap -- n )
|
|||
>r right r> data-nth ; inline
|
||||
|
||||
: data-set-nth ( entry n heap -- )
|
||||
>r [ swap set-entry-index ] 2keep r>
|
||||
>r [ >>index drop ] 2keep r>
|
||||
data>> set-nth-unsafe ;
|
||||
|
||||
: data-push ( entry heap -- n )
|
||||
|
@ -87,7 +87,7 @@ M: heap heap-size ( heap -- n )
|
|||
|
||||
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
|
||||
|
||||
: (heap-compare) drop [ entry-key ] compare ; inline
|
||||
: (heap-compare) drop [ key>> ] compare ; inline
|
||||
|
||||
M: min-heap heap-compare (heap-compare) +gt+ eq? ;
|
||||
|
||||
|
@ -161,11 +161,14 @@ M: heap heap-push* ( value key heap -- entry )
|
|||
M: heap heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
||||
ERROR: bad-heap-delete ;
|
||||
|
||||
M: bad-heap-delete summary
|
||||
drop "Invalid entry passed to heap-delete" ;
|
||||
|
||||
: entry>index ( entry heap -- n )
|
||||
over entry-heap eq? [
|
||||
"Invalid entry passed to heap-delete" throw
|
||||
] unless
|
||||
entry-index ;
|
||||
over heap>> eq? [ bad-heap-delete ] unless
|
||||
index>> ;
|
||||
|
||||
M: heap heap-delete ( entry heap -- )
|
||||
[ entry>index ] keep
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.x
|
||||
USING: arrays definitions generic assocs
|
||||
USING: accessors arrays definitions generic assocs
|
||||
io kernel namespaces prettyprint prettyprint.sections
|
||||
sequences words summary classes strings vocabs ;
|
||||
IN: help.topics
|
||||
|
@ -16,12 +16,12 @@ M: link >link ;
|
|||
M: vocab-spec >link ;
|
||||
M: object >link link boa ;
|
||||
|
||||
PREDICATE: word-link < link link-name word? ;
|
||||
PREDICATE: word-link < link name>> word? ;
|
||||
|
||||
M: link summary
|
||||
[
|
||||
"Link: " %
|
||||
link-name dup word? [ summary ] [ unparse ] if %
|
||||
name>> dup word? [ summary ] [ unparse ] if %
|
||||
] "" make ;
|
||||
|
||||
! Help articles
|
||||
|
@ -44,9 +44,7 @@ TUPLE: article title content loc ;
|
|||
|
||||
M: article article-name article-title ;
|
||||
|
||||
TUPLE: no-article name ;
|
||||
|
||||
: no-article ( name -- * ) \ no-article boa throw ;
|
||||
ERROR: no-article name ;
|
||||
|
||||
M: no-article summary
|
||||
drop "Help article does not exist" ;
|
||||
|
@ -60,11 +58,11 @@ M: object article-content article article-content ;
|
|||
M: object article-parent article-xref get at ;
|
||||
M: object set-article-parent article-xref get set-at ;
|
||||
|
||||
M: link article-name link-name article-name ;
|
||||
M: link article-title link-name article-title ;
|
||||
M: link article-content link-name article-content ;
|
||||
M: link article-parent link-name article-parent ;
|
||||
M: link set-article-parent link-name set-article-parent ;
|
||||
M: link article-name name>> article-name ;
|
||||
M: link article-title name>> article-title ;
|
||||
M: link article-content name>> article-content ;
|
||||
M: link article-parent name>> article-parent ;
|
||||
M: link set-article-parent name>> set-article-parent ;
|
||||
|
||||
! Special case: f help
|
||||
M: f article-name drop \ f article-name ;
|
||||
|
|
|
@ -35,8 +35,8 @@ HELP: buffer
|
|||
$nl
|
||||
"Buffers have two internal pointers:"
|
||||
{ $list
|
||||
{ { $link buffer-fill } " - the fill pointer, a write index where new data is added" }
|
||||
{ { $link buffer-pos } " - the position, a read index where data is consumed" }
|
||||
{ { $snippet "fill" } " - the fill pointer, a write index where new data is added" }
|
||||
{ { $snippet "pos" } " - the position, a read index where data is consumed" }
|
||||
} } ;
|
||||
|
||||
HELP: <buffer>
|
||||
|
|
|
@ -53,7 +53,7 @@ SYMBOL: +realtime-priority+
|
|||
dup handle>> swap status>> or ;
|
||||
|
||||
: process-running? ( process -- ? )
|
||||
process-handle >boolean ;
|
||||
handle>> >boolean ;
|
||||
|
||||
! Non-blocking process exit notification facility
|
||||
SYMBOL: processes
|
||||
|
@ -80,7 +80,7 @@ SYMBOL: wait-flag
|
|||
V{ } clone swap processes get set-at
|
||||
wait-flag get-global raise-flag ;
|
||||
|
||||
M: process hashcode* process-handle hashcode* ;
|
||||
M: process hashcode* handle>> hashcode* ;
|
||||
|
||||
: pass-environment? ( process -- ? )
|
||||
dup environment>> assoc-empty? not
|
||||
|
@ -99,9 +99,14 @@ M: process hashcode* process-handle hashcode* ;
|
|||
|
||||
GENERIC: >process ( obj -- process )
|
||||
|
||||
ERROR: process-already-started ;
|
||||
|
||||
M: process-already-started summary
|
||||
drop "Process has already been started once" ;
|
||||
|
||||
M: process >process
|
||||
dup process-started? [
|
||||
"Process has already been started once" throw
|
||||
process-already-started
|
||||
] when
|
||||
clone ;
|
||||
|
||||
|
@ -111,6 +116,8 @@ HOOK: current-process-handle io-backend ( -- handle )
|
|||
|
||||
HOOK: run-process* io-backend ( process -- handle )
|
||||
|
||||
ERROR: process-was-killed ;
|
||||
|
||||
: wait-for-process ( process -- status )
|
||||
[
|
||||
dup handle>>
|
||||
|
@ -119,7 +126,7 @@ HOOK: run-process* io-backend ( process -- handle )
|
|||
"process" suspend drop
|
||||
] when
|
||||
dup killed>>
|
||||
[ "Process was killed" throw ] [ status>> ] if
|
||||
[ process-was-killed ] [ status>> ] if
|
||||
] with-timeout ;
|
||||
|
||||
: run-detached ( desc -- process )
|
||||
|
@ -150,7 +157,7 @@ HOOK: kill-process* io-backend ( handle -- )
|
|||
|
||||
M: process timeout timeout>> ;
|
||||
|
||||
M: process set-timeout set-process-timeout ;
|
||||
M: process set-timeout swap >>timeout drop ;
|
||||
|
||||
M: process cancel-operation kill-process ;
|
||||
|
||||
|
@ -222,10 +229,12 @@ GENERIC: underlying-handle ( stream -- handle )
|
|||
|
||||
M: port underlying-handle handle>> ;
|
||||
|
||||
ERROR: invalid-duplex-stream ;
|
||||
|
||||
M: duplex-stream underlying-handle
|
||||
[ in>> underlying-handle ]
|
||||
[ out>> underlying-handle ] bi
|
||||
[ = [ "Invalid duplex stream" throw ] when ] keep ;
|
||||
[ = [ invalid-duplex-stream ] when ] keep ;
|
||||
|
||||
M: encoder underlying-handle
|
||||
stream>> underlying-handle ;
|
||||
|
|
|
@ -418,7 +418,7 @@ M: lambda-memoized reset-word
|
|||
: method-stack-effect ( method -- effect )
|
||||
dup "lambda" word-prop vars>>
|
||||
swap "method-generic" word-prop stack-effect
|
||||
dup [ effect-out ] when
|
||||
dup [ out>> ] when
|
||||
<effect> ;
|
||||
|
||||
M: lambda-method synopsis*
|
||||
|
|
|
@ -2,14 +2,14 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel sequences words effects
|
||||
stack-checker.transforms combinators assocs definitions
|
||||
quotations namespaces memoize ;
|
||||
quotations namespaces memoize accessors ;
|
||||
IN: macros
|
||||
|
||||
: real-macro-effect ( word -- effect' )
|
||||
"declared-effect" word-prop effect-in 1 <effect> ;
|
||||
"declared-effect" word-prop in>> 1 <effect> ;
|
||||
|
||||
: define-macro ( word definition -- )
|
||||
over "declared-effect" word-prop effect-in length >r
|
||||
over "declared-effect" word-prop in>> length >r
|
||||
2dup "macro" set-word-prop
|
||||
2dup over real-macro-effect memoize-quot [ call ] append define
|
||||
r> define-transform ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel hashtables sequences arrays words namespaces
|
||||
parser math assocs effects definitions quotations ;
|
||||
parser math assocs effects definitions quotations summary
|
||||
accessors ;
|
||||
IN: memoize
|
||||
|
||||
: packer ( n -- quot )
|
||||
|
@ -11,10 +12,10 @@ IN: memoize
|
|||
{ [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
|
||||
|
||||
: #in ( word -- n )
|
||||
stack-effect effect-in length ;
|
||||
stack-effect in>> length ;
|
||||
|
||||
: #out ( word -- n )
|
||||
stack-effect effect-out length ;
|
||||
stack-effect out>> length ;
|
||||
|
||||
: pack/unpack ( quot word -- newquot )
|
||||
[ dup #in unpacker % swap % #out packer % ] [ ] make ;
|
||||
|
@ -28,10 +29,13 @@ IN: memoize
|
|||
#out unpacker %
|
||||
] [ ] make ;
|
||||
|
||||
ERROR: too-many-arguments ;
|
||||
|
||||
M: too-many-arguments summary
|
||||
drop "There must be no more than 4 input and 4 output arguments" ;
|
||||
|
||||
: check-memoized ( word -- )
|
||||
dup #in 4 > swap #out 4 > or [
|
||||
"There must be no more than 4 input and 4 output arguments" throw
|
||||
] when ;
|
||||
dup #in 4 > swap #out 4 > or [ too-many-arguments ] when ;
|
||||
|
||||
: define-memoized ( word quot -- )
|
||||
over check-memoized
|
||||
|
|
|
@ -16,10 +16,13 @@ M: mirror at*
|
|||
[ nip object>> ] [ object-slots slot-named ] 2bi
|
||||
dup [ offset>> slot t ] [ 2drop f f ] if ;
|
||||
|
||||
ERROR: no-such-slot slot ;
|
||||
ERROR: read-only-slot slot ;
|
||||
|
||||
: check-set-slot ( val slot -- val offset )
|
||||
{
|
||||
{ [ dup not ] [ "No such slot" throw ] }
|
||||
{ [ dup read-only>> ] [ "Read only slot" throw ] }
|
||||
{ [ dup not ] [ no-such-slot ] }
|
||||
{ [ dup read-only>> ] [ read-only-slot ] }
|
||||
{ [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
|
||||
[ offset>> ]
|
||||
} cond ; inline
|
||||
|
|
|
@ -20,10 +20,10 @@ value connections dependencies ref locked? ;
|
|||
M: model hashcode* drop model hashcode* ;
|
||||
|
||||
: add-dependency ( dep model -- )
|
||||
model-dependencies push ;
|
||||
dependencies>> push ;
|
||||
|
||||
: remove-dependency ( dep model -- )
|
||||
model-dependencies delete ;
|
||||
dependencies>> delete ;
|
||||
|
||||
DEFER: add-connection
|
||||
|
||||
|
@ -32,14 +32,14 @@ GENERIC: model-activated ( model -- )
|
|||
M: model model-activated drop ;
|
||||
|
||||
: ref-model ( model -- n )
|
||||
dup model-ref 1+ dup rot set-model-ref ;
|
||||
[ 1+ ] change-ref ref>> ;
|
||||
|
||||
: unref-model ( model -- n )
|
||||
dup model-ref 1- dup rot set-model-ref ;
|
||||
[ 1- ] change-ref ref>> ;
|
||||
|
||||
: activate-model ( model -- )
|
||||
dup ref-model 1 = [
|
||||
dup model-dependencies
|
||||
dup dependencies>>
|
||||
[ dup activate-model dupd add-connection ] each
|
||||
model-activated
|
||||
] [
|
||||
|
@ -50,7 +50,7 @@ DEFER: remove-connection
|
|||
|
||||
: deactivate-model ( model -- )
|
||||
dup unref-model zero? [
|
||||
dup model-dependencies
|
||||
dup dependencies>>
|
||||
[ dup deactivate-model remove-connection ] with each
|
||||
] [
|
||||
drop
|
||||
|
@ -59,46 +59,45 @@ DEFER: remove-connection
|
|||
GENERIC: model-changed ( model observer -- )
|
||||
|
||||
: add-connection ( observer model -- )
|
||||
dup model-connections empty? [ dup activate-model ] when
|
||||
model-connections push ;
|
||||
dup connections>> empty? [ dup activate-model ] when
|
||||
connections>> push ;
|
||||
|
||||
: remove-connection ( observer model -- )
|
||||
[ model-connections delete ] keep
|
||||
dup model-connections empty? [ dup deactivate-model ] when
|
||||
[ connections>> delete ] keep
|
||||
dup connections>> empty? [ dup deactivate-model ] when
|
||||
drop ;
|
||||
|
||||
: with-locked-model ( model quot -- )
|
||||
swap
|
||||
t over set-model-locked?
|
||||
t >>locked?
|
||||
slip
|
||||
f swap set-model-locked? ; inline
|
||||
f >>locked? drop ; inline
|
||||
|
||||
GENERIC: update-model ( model -- )
|
||||
|
||||
M: model update-model drop ;
|
||||
|
||||
: notify-connections ( model -- )
|
||||
dup model-connections [ model-changed ] with each ;
|
||||
dup connections>> [ model-changed ] with each ;
|
||||
|
||||
: set-model ( value model -- )
|
||||
dup model-locked? [
|
||||
dup locked?>> [
|
||||
2drop
|
||||
] [
|
||||
dup [
|
||||
[ set-model-value ] keep
|
||||
[ update-model ] keep
|
||||
notify-connections
|
||||
swap >>value
|
||||
[ update-model ] [ notify-connections ] bi
|
||||
] with-locked-model
|
||||
] if ;
|
||||
|
||||
: ((change-model)) ( model quot -- newvalue model )
|
||||
over >r >r model-value r> call r> ; inline
|
||||
over >r >r value>> r> call r> ; inline
|
||||
|
||||
: change-model ( model quot -- )
|
||||
((change-model)) set-model ; inline
|
||||
|
||||
: (change-model) ( model quot -- )
|
||||
((change-model)) set-model-value ; inline
|
||||
((change-model)) (>>value) ; inline
|
||||
|
||||
GENERIC: range-value ( model -- value )
|
||||
GENERIC: range-page-value ( model -- value )
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
opengl.gl assocs vocabs.loader sequences ;
|
||||
opengl.gl assocs vocabs.loader sequences accessors ;
|
||||
IN: opengl
|
||||
|
||||
HELP: gl-color
|
||||
|
@ -91,17 +91,17 @@ HELP: do-attribs
|
|||
HELP: sprite
|
||||
{ $class-description "A sprite is an OpenGL texture together with a display list which renders a textured quad. Sprites are used to draw text in the UI. Sprites have the following slots:"
|
||||
{ $list
|
||||
{ { $link sprite-dlist } " - an OpenGL display list ID" }
|
||||
{ { $link sprite-texture } " - an OpenGL texture ID" }
|
||||
{ { $link sprite-loc } " - top-left corner of the sprite" }
|
||||
{ { $link sprite-dim } " - dimensions of the sprite" }
|
||||
{ { $link sprite-dim2 } " - dimensions of the sprite, rounded up to the nearest powers of two" }
|
||||
{ { $link dlist>> } " - an OpenGL display list ID" }
|
||||
{ { $link texture>> } " - an OpenGL texture ID" }
|
||||
{ { $link loc>> } " - top-left corner of the sprite" }
|
||||
{ { $link dim>> } " - dimensions of the sprite" }
|
||||
{ { $link dim2>> } " - dimensions of the sprite, rounded up to the nearest powers of two" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: gray-texture
|
||||
{ $values { "sprite" sprite } { "pixmap" "an alien or byte array" } { "id" "an OpenGL texture ID" } }
|
||||
{ $description "Creates a new OpenGL texture from a 1 byte per pixel image whose dimensions are equal to " { $link sprite-dim2 } "." } ;
|
||||
{ $description "Creates a new OpenGL texture from a 1 byte per pixel image whose dimensions are equal to " { $snippet "dim2" } "." } ;
|
||||
|
||||
HELP: gen-dlist
|
||||
{ $values { "id" integer } }
|
||||
|
|
|
@ -180,9 +180,9 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
: <sprite> ( loc dim dim2 -- sprite )
|
||||
f f sprite boa ;
|
||||
|
||||
: sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ;
|
||||
: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
|
||||
|
||||
: sprite-width ( sprite -- w ) sprite-dim first ;
|
||||
: sprite-width ( sprite -- w ) dim>> first ;
|
||||
|
||||
: gray-texture ( sprite pixmap -- id )
|
||||
gen-texture [
|
||||
|
@ -223,10 +223,10 @@ PRIVATE>
|
|||
dup top-left dup top-right dup bottom-right bottom-left ;
|
||||
|
||||
: draw-sprite ( sprite -- )
|
||||
dup sprite-loc gl-translate
|
||||
GL_TEXTURE_2D over sprite-texture glBindTexture
|
||||
dup loc>> gl-translate
|
||||
GL_TEXTURE_2D over texture>> glBindTexture
|
||||
init-texture
|
||||
GL_QUADS [ sprite-dim2 four-sides ] do-state
|
||||
GL_QUADS [ dim2>> four-sides ] do-state
|
||||
GL_TEXTURE_2D 0 glBindTexture ;
|
||||
|
||||
: rect-vertices ( lower-left upper-right -- )
|
||||
|
@ -243,14 +243,14 @@ PRIVATE>
|
|||
] do-matrix ;
|
||||
|
||||
: init-sprite ( texture sprite -- )
|
||||
[ set-sprite-texture ] keep
|
||||
[ make-sprite-dlist ] keep set-sprite-dlist ;
|
||||
swap >>texture
|
||||
dup make-sprite-dlist >>dlist drop ;
|
||||
|
||||
: delete-dlist ( id -- ) 1 glDeleteLists ;
|
||||
|
||||
: free-sprite ( sprite -- )
|
||||
dup sprite-dlist delete-dlist
|
||||
sprite-texture delete-texture ;
|
||||
[ dlist>> delete-dlist ]
|
||||
[ texture>> delete-texture ] bi ;
|
||||
|
||||
: free-sprites ( sprites -- )
|
||||
[ nip [ free-sprite ] when* ] assoc-each ;
|
||||
|
|
|
@ -2,7 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
|
|||
kernel math namespaces parser prettyprint prettyprint.config
|
||||
prettyprint.sections sequences tools.test vectors words
|
||||
effects splitting generic.standard prettyprint.private
|
||||
continuations generic compiler.units tools.walker eval ;
|
||||
continuations generic compiler.units tools.walker eval
|
||||
accessors ;
|
||||
IN: prettyprint.tests
|
||||
|
||||
[ "4" ] [ 4 unparse ] unit-test
|
||||
|
@ -296,7 +297,7 @@ M: class-see-layout class-see-layout ;
|
|||
[ \ class-see-layout see-methods ] with-string-writer "\n" split
|
||||
] unit-test
|
||||
|
||||
[ ] [ \ effect-in synopsis drop ] unit-test
|
||||
[ ] [ \ in>> synopsis drop ] unit-test
|
||||
|
||||
! Regression
|
||||
[ t ] [
|
||||
|
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel quotations help.syntax help.markup
|
||||
io.sockets strings calendar ;
|
||||
IN: smtp
|
||||
|
||||
HELP: smtp-server
|
||||
{ $description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
|
||||
|
||||
HELP: smtp-read-timeout
|
||||
{ $description "Holds an " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
|
||||
|
||||
HELP: with-smtp-connection
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." } ;
|
||||
|
||||
HELP: <email>
|
||||
{ $values { "email" email } }
|
||||
{ $description "Creates an empty " { $link email } " object." } ;
|
||||
|
||||
HELP: send-email
|
||||
{ $values { "email" email } }
|
||||
{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable. The required slots are " { $snippet "from" } " and " { $snippet "to" } "." }
|
||||
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: accessors smtp ;"
|
||||
"<email>"
|
||||
" \"groucho@marx.bros\" >>from"
|
||||
" { \"chico@marx.bros\" \"harpo@marx.bros\" } >>to"
|
||||
" { \"gummo@marx.bros\" } >>cc"
|
||||
" { \"zeppo@marx.bros\" } >>bcc"
|
||||
" \"Pickup line\" >>subject"
|
||||
" \"If I said you had a beautiful body, would you hold it against me?\" >>body"
|
||||
"send-email"
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "smtp" "SMTP Client Library"
|
||||
"Start by creating a new email object:"
|
||||
{ $subsection <email> }
|
||||
"Set the " { $snippet "from" } " slot to a " { $link string } "." $nl
|
||||
"Set the recipient fields, " { $snippet "to" } ", " { $snippet "cc" } ", and " { $snippet "bcc" } ", to arrays of strings."
|
||||
"Set the " { $snippet "subject" } " to a " { $link string } "." $nl
|
||||
"Set the " { $snippet "body" } " to a " { $link string } "." $nl ;
|
|
@ -1,6 +1,6 @@
|
|||
USING: smtp tools.test io.streams.string io.sockets threads
|
||||
smtp.server kernel sequences namespaces logging accessors
|
||||
assocs sorting ;
|
||||
assocs sorting smtp.private ;
|
||||
IN: smtp.tests
|
||||
|
||||
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
|
||||
! Slava Pestov.
|
||||
! Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays namespaces io io.timeouts kernel logging io.sockets
|
||||
sequences combinators sequences.lib splitting assocs strings
|
||||
|
@ -9,7 +9,7 @@ IN: smtp
|
|||
|
||||
SYMBOL: smtp-domain
|
||||
SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
|
||||
SYMBOL: read-timeout 1 minutes read-timeout set-global
|
||||
SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global
|
||||
SYMBOL: esmtp t esmtp set-global
|
||||
|
||||
LOG: log-smtp-connection NOTICE ( addrspec -- )
|
||||
|
@ -19,7 +19,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
|
|||
dup log-smtp-connection
|
||||
ascii [
|
||||
smtp-domain [ host-name or ] change
|
||||
read-timeout get timeouts
|
||||
smtp-read-timeout get timeouts
|
||||
call
|
||||
] with-client ; inline
|
||||
|
||||
|
@ -33,6 +33,7 @@ TUPLE: email
|
|||
|
||||
: <email> ( -- email ) email new ;
|
||||
|
||||
<PRIVATE
|
||||
: crlf ( -- ) "\r\n" write ;
|
||||
|
||||
: command ( string -- ) write crlf flush ;
|
||||
|
@ -151,7 +152,7 @@ ERROR: invalid-header-string string ;
|
|||
] "" make ;
|
||||
|
||||
: extract-email ( recepient -- email )
|
||||
#! This could be much smarter.
|
||||
! This could be much smarter.
|
||||
" " last-split1 swap or "<" ?head drop ">" ?tail drop ;
|
||||
|
||||
: email>headers ( email -- hashtable )
|
||||
|
@ -179,6 +180,7 @@ ERROR: invalid-header-string string ;
|
|||
body>> send-body get-ok
|
||||
quit get-ok
|
||||
] with-smtp-connection ;
|
||||
PRIVATE>
|
||||
|
||||
: send-email ( email -- )
|
||||
[ email>headers ] keep (send-email) ;
|
||||
|
@ -200,5 +202,3 @@ ERROR: invalid-header-string string ;
|
|||
! : cram-md5-auth ( key login -- )
|
||||
! "AUTH CRAM-MD5\r\n" get-ok
|
||||
! (cram-md5-auth) "\r\n" append get-ok ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
@ -31,7 +31,7 @@ M: word reset
|
|||
|
||||
: word-inputs ( word -- seq )
|
||||
stack-effect [
|
||||
>r datastack r> effect-in length tail*
|
||||
>r datastack r> in>> length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
|
@ -44,7 +44,7 @@ M: word reset
|
|||
: leaving ( str -- )
|
||||
"/-- Leaving: " write dup .
|
||||
stack-effect [
|
||||
>r datastack r> effect-out length tail* stack.
|
||||
>r datastack r> out>> length tail* stack.
|
||||
] [
|
||||
.s
|
||||
] if* "\\--" print flush ;
|
||||
|
|
|
@ -53,7 +53,7 @@ TUPLE: library path abi dll ;
|
|||
over dup [ dlopen ] when \ library boa ;
|
||||
|
||||
: load-library ( name -- dll )
|
||||
library dup [ library-dll ] when ;
|
||||
library dup [ dll>> ] when ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get set-at ;
|
||||
|
|
|
@ -4,7 +4,7 @@ tools.test vectors words quotations classes classes.algebra
|
|||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units growable
|
||||
random stack-checker effects kernel.private sbufs math.order
|
||||
classes.tuple ;
|
||||
classes.tuple accessors ;
|
||||
IN: classes.algebra.tests
|
||||
|
||||
\ class< must-infer
|
||||
|
@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
|
|||
10 [
|
||||
[ ] [
|
||||
20 [ random-op ] [ ] replicate-as
|
||||
[ infer effect-in [ random-class ] times ] keep
|
||||
[ infer in>> [ random-class ] times ] keep
|
||||
call
|
||||
drop
|
||||
] unit-test
|
||||
|
@ -238,7 +238,7 @@ UNION: z1 b1 c1 ;
|
|||
20 [
|
||||
[ t ] [
|
||||
20 [ random-boolean-op ] [ ] replicate-as dup .
|
||||
[ infer effect-in [ random-boolean ] replicate dup . ] keep
|
||||
[ infer in>> [ random-boolean ] replicate dup . ] keep
|
||||
|
||||
[ >r [ ] each r> call ] 2keep
|
||||
|
||||
|
|
|
@ -29,8 +29,8 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
|
||||
: change-lexer-column ( lexer quot -- )
|
||||
swap
|
||||
[ dup lexer-column swap lexer-line-text rot call ] keep
|
||||
set-lexer-column ; inline
|
||||
[ [ column>> ] [ line-text>> ] bi rot call ] keep
|
||||
(>>column) ; inline
|
||||
|
||||
GENERIC: skip-blank ( lexer -- )
|
||||
|
||||
|
@ -45,16 +45,18 @@ M: lexer skip-word ( lexer -- )
|
|||
] change-lexer-column ;
|
||||
|
||||
: still-parsing? ( lexer -- ? )
|
||||
dup lexer-line swap lexer-text length <= ;
|
||||
[ line>> ] [ text>> ] bi length <= ;
|
||||
|
||||
: still-parsing-line? ( lexer -- ? )
|
||||
dup lexer-column swap lexer-line-length < ;
|
||||
[ column>> ] [ line-length>> ] bi < ;
|
||||
|
||||
: (parse-token) ( lexer -- str )
|
||||
[ lexer-column ] keep
|
||||
[ skip-word ] keep
|
||||
[ lexer-column ] keep
|
||||
lexer-line-text subseq ;
|
||||
{
|
||||
[ column>> ]
|
||||
[ skip-word ]
|
||||
[ column>> ]
|
||||
[ line-text>> ]
|
||||
} cleave subseq ;
|
||||
|
||||
: parse-token ( lexer -- str/f )
|
||||
dup still-parsing? [
|
||||
|
@ -68,7 +70,7 @@ M: lexer skip-word ( lexer -- )
|
|||
ERROR: unexpected want got ;
|
||||
|
||||
PREDICATE: unexpected-eof < unexpected
|
||||
unexpected-got not ;
|
||||
got>> not ;
|
||||
|
||||
: unexpected-eof ( word -- * ) f unexpected ;
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel combinators fry namespaces quotations hashtables
|
||||
sequences assocs arrays stack-checker effects math math.ranges
|
||||
generalizations macros continuations random locals ;
|
||||
generalizations macros continuations random locals accessors ;
|
||||
|
||||
IN: combinators.lib
|
||||
|
||||
|
@ -63,7 +63,7 @@ IN: combinators.lib
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MACRO: preserving ( predicate -- quot )
|
||||
dup infer effect-in
|
||||
dup infer in>>
|
||||
dup 1+
|
||||
'[ , , nkeep , nrot ] ;
|
||||
|
||||
|
|
|
@ -40,8 +40,8 @@ M: no-inverse summary
|
|||
|
||||
: constant-word? ( word -- ? )
|
||||
stack-effect
|
||||
[ effect-out length 1 = ] keep
|
||||
effect-in length 0 = and ;
|
||||
[ out>> length 1 = ] keep
|
||||
in>> length 0 = and ;
|
||||
|
||||
: assure-constant ( constant -- quot )
|
||||
dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
|
||||
|
@ -65,7 +65,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
|
||||
: enough? ( stack word -- ? )
|
||||
dup deferred? [ 2drop f ] [
|
||||
[ >r length r> 1quotation infer effect-in >= ]
|
||||
[ >r length r> 1quotation infer in>> >= ]
|
||||
[ 3drop f ] recover
|
||||
] if ;
|
||||
|
||||
|
@ -235,11 +235,11 @@ DEFER: _
|
|||
] recover ; inline
|
||||
|
||||
: true-out ( quot effect -- quot' )
|
||||
effect-out [ ndrop ] curry
|
||||
out>> [ ndrop ] curry
|
||||
[ t ] 3compose ;
|
||||
|
||||
: false-recover ( effect -- quot )
|
||||
effect-in [ ndrop f ] curry [ recover-fail ] curry ;
|
||||
in>> [ ndrop f ] curry [ recover-fail ] curry ;
|
||||
|
||||
: [matches?] ( quot -- undoes?-quot )
|
||||
[undo] dup infer [ true-out ] keep false-recover curry ;
|
||||
|
|
|
@ -5,7 +5,7 @@
|
|||
! Updated by Chris Double, September 2006
|
||||
|
||||
USING: arrays kernel sequences math vectors arrays namespaces
|
||||
quotations parser effects stack-checker words ;
|
||||
quotations parser effects stack-checker words accessors ;
|
||||
IN: promises
|
||||
|
||||
TUPLE: promise quot forced? value ;
|
||||
|
@ -23,14 +23,14 @@ TUPLE: promise quot forced? value ;
|
|||
#! Force the given promise leaving the value of calling the
|
||||
#! promises quotation on the stack. Re-forcing the promise
|
||||
#! will return the same value and not recall the quotation.
|
||||
dup promise-forced? [
|
||||
dup promise-quot call over set-promise-value
|
||||
t over set-promise-forced?
|
||||
dup forced?>> [
|
||||
dup quot>> call >>value
|
||||
t >>forced?
|
||||
] unless
|
||||
promise-value ;
|
||||
value>> ;
|
||||
|
||||
: stack-effect-in ( quot word -- n )
|
||||
stack-effect [ ] [ infer ] ?if effect-in length ;
|
||||
stack-effect [ ] [ infer ] ?if in>> length ;
|
||||
|
||||
: make-lazy-quot ( word quot -- quot )
|
||||
[
|
||||
|
|
|
@ -11,6 +11,8 @@ TUPLE: regexp
|
|||
nfa-table
|
||||
dfa-table
|
||||
minimized-table
|
||||
{ nfa-traversal-flags hashtable }
|
||||
{ dfa-traversal-flags hashtable }
|
||||
{ state integer }
|
||||
{ new-states vector }
|
||||
{ visited-states hashtable } ;
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators fry kernel locals
|
||||
math math.order regexp2.nfa regexp2.transition-tables sequences
|
||||
sets sorting vectors regexp2.utils sequences.lib ;
|
||||
sets sorting vectors regexp2.utils sequences.lib combinators.lib
|
||||
sequences.deep ;
|
||||
USING: io prettyprint threads ;
|
||||
IN: regexp2.dfa
|
||||
|
||||
|
@ -42,7 +43,7 @@ IN: regexp2.dfa
|
|||
dupd pop dup pick find-transitions rot
|
||||
[
|
||||
[ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
|
||||
>r swapd transition boa r> dfa-table>> add-transition
|
||||
>r swapd transition make-transition r> dfa-table>> add-transition
|
||||
] curry with each
|
||||
new-transitions
|
||||
] if-empty ;
|
||||
|
@ -66,5 +67,13 @@ IN: regexp2.dfa
|
|||
[ >>start-state drop ] keep
|
||||
1vector >>new-states drop ;
|
||||
|
||||
: set-traversal-flags ( regexp -- )
|
||||
[ dfa-table>> transitions>> keys ]
|
||||
[ nfa-traversal-flags>> ]
|
||||
bi 2drop ;
|
||||
|
||||
: construct-dfa ( regexp -- )
|
||||
[ set-initial-state ] [ new-transitions ] [ set-final-states ] tri ;
|
||||
[ set-initial-state ]
|
||||
[ new-transitions ]
|
||||
[ set-final-states ] tri ;
|
||||
! [ set-traversal-flags ] quad ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays assocs grouping kernel regexp2.backend
|
||||
locals math namespaces regexp2.parser sequences state-tables fry
|
||||
quotations math.order math.ranges vectors unicode.categories
|
||||
regexp2.utils regexp2.transition-tables words sequences.lib ;
|
||||
regexp2.utils regexp2.transition-tables words sequences.lib sets ;
|
||||
IN: regexp2.nfa
|
||||
|
||||
SYMBOL: negation-mode
|
||||
|
@ -11,6 +11,12 @@ SYMBOL: negation-mode
|
|||
|
||||
SINGLETON: eps
|
||||
|
||||
MIXIN: traversal-flag
|
||||
SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
|
||||
SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
|
||||
SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
|
||||
SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
|
||||
|
||||
: next-state ( regexp -- state )
|
||||
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
|
||||
|
||||
|
@ -30,14 +36,18 @@ GENERIC: nfa-node ( node -- )
|
|||
stack [ regexp stack>> ]
|
||||
table [ regexp nfa-table>> ] |
|
||||
negated? [
|
||||
s0 f obj class boa table add-transition
|
||||
s0 f obj class make-transition table add-transition
|
||||
s0 s1 <default-transition> table add-transition
|
||||
] [
|
||||
s0 s1 obj class boa table add-transition
|
||||
s0 s1 obj class make-transition table add-transition
|
||||
] if
|
||||
s0 s1 2array stack push
|
||||
t s1 table final-states>> set-at ] ;
|
||||
|
||||
: add-traversal-flag ( flag -- )
|
||||
stack peek second
|
||||
current-regexp get nfa-traversal-flags>> push-at ;
|
||||
|
||||
:: concatenate-nodes ( -- )
|
||||
[let* | regexp [ current-regexp get ]
|
||||
stack [ regexp stack>> ]
|
||||
|
@ -116,6 +126,14 @@ M: negation nfa-node ( node -- )
|
|||
term>> nfa-node
|
||||
negation-mode dec ;
|
||||
|
||||
M: lookahead nfa-node ( node -- )
|
||||
eps literal-transition add-simple-entry
|
||||
lookahead-on add-traversal-flag
|
||||
term>> nfa-node
|
||||
eps literal-transition add-simple-entry
|
||||
lookahead-off add-traversal-flag
|
||||
2 [ concatenate-nodes ] times ;
|
||||
|
||||
: construct-nfa ( regexp -- )
|
||||
[
|
||||
reset-regexp
|
||||
|
|
|
@ -151,11 +151,13 @@ ERROR: bad-special-group string ;
|
|||
DEFER: nested-parse-regexp
|
||||
: (parse-special-group) ( -- )
|
||||
read1 {
|
||||
{ [ dup CHAR: # = ]
|
||||
[ drop nested-parse-regexp pop-stack drop ] }
|
||||
{ [ dup CHAR: : = ]
|
||||
[ drop nested-parse-regexp pop-stack make-non-capturing-group ] }
|
||||
{ [ dup CHAR: = = ]
|
||||
[ drop nested-parse-regexp pop-stack make-positive-lookahead ] }
|
||||
{ [ dup CHAR: = = ]
|
||||
{ [ dup CHAR: ! = ]
|
||||
[ drop nested-parse-regexp pop-stack make-negative-lookahead ] }
|
||||
{ [ dup CHAR: > = ]
|
||||
[ drop nested-parse-regexp pop-stack make-independent-group ] }
|
||||
|
@ -385,25 +387,25 @@ DEFER: handle-left-bracket
|
|||
: nested-parse-regexp ( -- )
|
||||
beginning-of-group push-stack (parse-regexp) ;
|
||||
|
||||
: ((parse-regexp)) ( token -- )
|
||||
: ((parse-regexp)) ( token -- ? )
|
||||
{
|
||||
{ CHAR: . [ handle-dot ] }
|
||||
{ CHAR: ( [ handle-left-parenthesis ] }
|
||||
{ CHAR: ) [ handle-right-parenthesis ] }
|
||||
{ CHAR: | [ handle-pipe ] }
|
||||
{ CHAR: ? [ handle-question ] }
|
||||
{ CHAR: * [ handle-star ] }
|
||||
{ CHAR: + [ handle-plus ] }
|
||||
{ CHAR: { [ handle-left-brace ] }
|
||||
{ CHAR: [ [ handle-left-bracket ] }
|
||||
{ CHAR: ^ [ handle-front-anchor ] }
|
||||
{ CHAR: $ [ handle-back-anchor ] }
|
||||
{ CHAR: \ [ handle-escape ] }
|
||||
[ <constant> push-stack ]
|
||||
{ CHAR: . [ handle-dot t ] }
|
||||
{ CHAR: ( [ handle-left-parenthesis t ] }
|
||||
{ CHAR: ) [ handle-right-parenthesis f ] }
|
||||
{ CHAR: | [ handle-pipe t ] }
|
||||
{ CHAR: ? [ handle-question t ] }
|
||||
{ CHAR: * [ handle-star t ] }
|
||||
{ CHAR: + [ handle-plus t ] }
|
||||
{ CHAR: { [ handle-left-brace t ] }
|
||||
{ CHAR: [ [ handle-left-bracket t ] }
|
||||
{ CHAR: ^ [ handle-front-anchor t ] }
|
||||
{ CHAR: $ [ handle-back-anchor t ] }
|
||||
{ CHAR: \ [ handle-escape t ] }
|
||||
[ <constant> push-stack t ]
|
||||
} case ;
|
||||
|
||||
: (parse-regexp) ( -- )
|
||||
read1 [ ((parse-regexp)) (parse-regexp) ] when* ;
|
||||
read1 [ ((parse-regexp)) [ (parse-regexp) ] when ] when* ;
|
||||
|
||||
: parse-regexp ( regexp -- )
|
||||
dup current-regexp [
|
||||
|
|
|
@ -222,6 +222,8 @@ IN: regexp2-tests
|
|||
<regexp> drop
|
||||
] unit-test
|
||||
|
||||
! Comment
|
||||
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -12,6 +12,8 @@ IN: regexp2
|
|||
<transition-table> >>nfa-table
|
||||
<transition-table> >>dfa-table
|
||||
<transition-table> >>minimized-table
|
||||
H{ } clone >>nfa-traversal-flags
|
||||
H{ } clone >>dfa-traversal-flags
|
||||
reset-regexp ;
|
||||
|
||||
: construct-regexp ( regexp -- regexp' )
|
||||
|
@ -26,7 +28,8 @@ IN: regexp2
|
|||
<dfa-traverser> do-match return-match ;
|
||||
|
||||
: matches? ( string regexp -- ? )
|
||||
dupd match [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
|
||||
dupd match
|
||||
[ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
|
||||
|
||||
: match-head ( string regexp -- end ) match length>> 1- ;
|
||||
|
||||
|
|
|
@ -1,19 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs fry hashtables kernel sequences
|
||||
vectors ;
|
||||
vectors regexp2.utils ;
|
||||
IN: regexp2.transition-tables
|
||||
|
||||
: insert-at ( value key hash -- )
|
||||
2dup at* [
|
||||
2nip push
|
||||
] [
|
||||
drop >r >r dup vector? [ 1vector ] unless r> r> set-at
|
||||
] if ;
|
||||
|
||||
: ?insert-at ( value key hash/f -- hash )
|
||||
[ H{ } clone ] unless* [ insert-at ] keep ;
|
||||
|
||||
TUPLE: transition from to obj ;
|
||||
TUPLE: literal-transition < transition ;
|
||||
TUPLE: class-transition < transition ;
|
||||
|
@ -22,13 +12,20 @@ TUPLE: default-transition < transition ;
|
|||
TUPLE: literal obj ;
|
||||
TUPLE: class obj ;
|
||||
TUPLE: default ;
|
||||
: <literal-transition> ( from to obj -- transition ) literal-transition boa ;
|
||||
: <class-transition> ( from to obj -- transition ) class-transition boa ;
|
||||
: <default-transition> ( from to -- transition ) t default-transition boa ;
|
||||
: make-transition ( from to obj class -- obj )
|
||||
new
|
||||
swap >>obj
|
||||
swap >>to
|
||||
swap >>from ;
|
||||
|
||||
TUPLE: transition-table transitions
|
||||
literals classes defaults
|
||||
start-state final-states ;
|
||||
: <literal-transition> ( from to obj -- transition )
|
||||
literal-transition make-transition ;
|
||||
: <class-transition> ( from to obj -- transition )
|
||||
class-transition make-transition ;
|
||||
: <default-transition> ( from to -- transition )
|
||||
t default-transition make-transition ;
|
||||
|
||||
TUPLE: transition-table transitions start-state final-states ;
|
||||
|
||||
: <transition-table> ( -- transition-table )
|
||||
transition-table new
|
||||
|
@ -36,7 +33,7 @@ TUPLE: transition-table transitions
|
|||
H{ } clone >>final-states ;
|
||||
|
||||
: set-transition ( transition hash -- )
|
||||
>r [ to>> ] [ obj>> ] [ from>> ] tri r>
|
||||
[ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
|
||||
2dup at* [ 2nip insert-at ]
|
||||
[ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
|
||||
|
||||
|
|
|
@ -3,25 +3,31 @@
|
|||
USING: accessors assocs combinators combinators.lib kernel
|
||||
math math.ranges quotations sequences regexp2.parser
|
||||
regexp2.classes combinators.short-circuit assocs.lib
|
||||
sequences.lib ;
|
||||
sequences.lib regexp2.utils ;
|
||||
IN: regexp2.traversal
|
||||
|
||||
TUPLE: dfa-traverser
|
||||
dfa-table
|
||||
traversal-flags
|
||||
capture-groups
|
||||
{ capture-group-index integer }
|
||||
{ lookahead-counter integer }
|
||||
last-state current-state
|
||||
text
|
||||
start-index current-index
|
||||
matches ;
|
||||
|
||||
: <dfa-traverser> ( text regexp -- match )
|
||||
dfa-table>>
|
||||
[ dfa-table>> ] [ traversal-flags>> ] bi
|
||||
dfa-traverser new
|
||||
swap >>traversal-flags
|
||||
swap [ start-state>> >>current-state ] keep
|
||||
>>dfa-table
|
||||
swap >>text
|
||||
0 >>start-index
|
||||
0 >>current-index
|
||||
V{ } clone >>matches ;
|
||||
V{ } clone >>matches
|
||||
V{ } clone >>capture-groups ;
|
||||
|
||||
: final-state? ( dfa-traverser -- ? )
|
||||
[ current-state>> ] [ dfa-table>> final-states>> ] bi
|
||||
|
@ -39,8 +45,7 @@ TUPLE: dfa-traverser
|
|||
] when text-finished? ;
|
||||
|
||||
: increment-state ( dfa-traverser state -- dfa-traverser )
|
||||
>r [ 1+ ] change-current-index
|
||||
dup current-state>> >>last-state r>
|
||||
>r [ 1+ ] change-current-index dup current-state>> >>last-state r>
|
||||
first >>current-state ;
|
||||
|
||||
: match-failed ( dfa-traverser -- dfa-traverser )
|
||||
|
@ -49,9 +54,6 @@ TUPLE: dfa-traverser
|
|||
: match-literal ( transition from-state table -- to-state/f )
|
||||
transitions>> [ at ] [ 2drop f ] if-at ;
|
||||
|
||||
: assoc-with ( param assoc quot -- assoc curry )
|
||||
swapd [ [ -rot ] dip call ] 2curry ; inline
|
||||
|
||||
: match-class ( transition from-state table -- to-state/f )
|
||||
transitions>> at* [
|
||||
[ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
|
||||
|
@ -65,7 +67,10 @@ TUPLE: dfa-traverser
|
|||
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
|
||||
|
||||
: setup-match ( match -- obj state dfa-table )
|
||||
{ current-index>> text>> current-state>> dfa-table>> } get-slots
|
||||
{
|
||||
[ current-index>> ] [ text>> ]
|
||||
[ current-state>> ] [ dfa-table>> ]
|
||||
} cleave
|
||||
[ nth ] 2dip ;
|
||||
|
||||
: do-match ( dfa-traverser -- dfa-traverser )
|
||||
|
|
|
@ -3,18 +3,32 @@
|
|||
USING: accessors arrays assocs combinators.lib io kernel
|
||||
math math.order namespaces regexp2.backend sequences
|
||||
sequences.lib unicode.categories math.ranges fry
|
||||
combinators.short-circuit ;
|
||||
combinators.short-circuit vectors ;
|
||||
IN: regexp2.utils
|
||||
|
||||
: (while-changes) ( obj quot pred pred-ret -- obj )
|
||||
! quot: ( obj -- obj' )
|
||||
! pred: ( obj -- <=> )
|
||||
>r >r dup slip r> pick over call r> dupd =
|
||||
[ 3drop ] [ (while-changes) ] if ; inline
|
||||
[ 3drop ] [ (while-changes) ] if ; inline recursive
|
||||
|
||||
: while-changes ( obj quot pred -- obj' )
|
||||
pick over call (while-changes) ; inline
|
||||
|
||||
: assoc-with ( param assoc quot -- assoc curry )
|
||||
swapd [ [ -rot ] dip call ] 2curry ; inline
|
||||
|
||||
: insert-at ( value key hash -- )
|
||||
2dup at* [
|
||||
2nip push
|
||||
] [
|
||||
drop
|
||||
[ dup vector? [ 1vector ] unless ] 2dip set-at
|
||||
] if ;
|
||||
|
||||
: ?insert-at ( value key hash/f -- hash )
|
||||
[ H{ } clone ] unless* [ insert-at ] keep ;
|
||||
|
||||
: last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
|
||||
: push1 ( obj -- ) input-stream get stream>> push ;
|
||||
: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
|
||||
|
|
Loading…
Reference in New Issue